home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / CGI.pm < prev    next >
Encoding:
Perl POD Document  |  1999-12-28  |  126.4 KB  |  4,404 lines
  1. package CGI;
  2. require 5.001;
  3.  
  4.  
  5.  
  6.  
  7.  
  8. $AUTOLOAD_DEBUG=0;
  9.  
  10. $NPH=0;
  11.  
  12. $PRIVATE_TEMPFILES=0;
  13.  
  14. $CGI::revision = '$Id: CGI.pm,v 2.36 1997/5/10 8:22 lstein Exp $';
  15. $CGI::VERSION='2.36';
  16.  
  17.  
  18.  
  19.  
  20. unless ($OS) {
  21.     unless ($OS = $^O) {
  22.     require Config;
  23.     $OS = $Config::Config{'osname'};
  24.     }
  25. }
  26. if ($OS=~/Win/i) {
  27.     $OS = 'WINDOWS';
  28. } elsif ($OS=~/vms/i) {
  29.     $OS = 'VMS';
  30. } elsif ($OS=~/Mac/i) {
  31.     $OS = 'MACINTOSH';
  32. } elsif ($OS=~/os2/i) {
  33.     $OS = 'OS2';
  34. } else {
  35.     $OS = 'UNIX';
  36. }
  37.  
  38. $needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/;
  39.  
  40. $DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
  41. $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
  42.  
  43. $SL = {
  44.     UNIX=>'/',
  45.     OS2=>'\\',
  46.     WINDOWS=>'\\',
  47.     MACINTOSH=>':',
  48.     VMS=>'\\'
  49.     }->{$OS};
  50.  
  51. $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
  52.  
  53. if (defined($ENV{'GATEWAY_INTERFACE'}) && ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)) {
  54.     $NPH++;
  55.     $| = 1;
  56.     $SEQNO = 1;
  57. }
  58.  
  59. $CRLF = "\015\012";
  60.  
  61. if ($needs_binmode) {
  62.     $CGI::DefaultClass->binmode(main::STDOUT);
  63.     $CGI::DefaultClass->binmode(main::STDIN);
  64.     $CGI::DefaultClass->binmode(main::STDERR);
  65. }
  66.  
  67.  
  68. %EXPORT_TAGS = (
  69.           ':html2'=>[h1..h6,qw/p br hr ol ul li dl dt dd menu code var strong em
  70.              tt i b blockquote pre img a address cite samp dfn html head
  71.              base body link nextid title meta kbd start_html end_html
  72.              input Select option/],
  73.           ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont style span/],
  74.           ':netscape'=>[qw/blink frameset frame script font fontsize center/],
  75.           ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group 
  76.                submit reset defaults radio_group popup_menu button autoEscape
  77.                scrolling_list image_button start_form end_form startform endform
  78.                start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
  79.           ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump
  80.                raw_cookie request_method query_string accept user_agent remote_host 
  81.                remote_addr referer server_name server_software server_port server_protocol
  82.                virtual_host remote_ident auth_type http use_named_parameters
  83.                remote_user user_name header redirect import_names put/],
  84.           ':ssl' => [qw/https/],
  85.           ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
  86.           ':html' => [qw/:html2 :html3 :netscape/],
  87.           ':standard' => [qw/:html2 :form :cgi/],
  88.           ':all' => [qw/:html2 :html3 :netscape :form :cgi/]
  89.      );
  90.  
  91. sub import {
  92.     my $self = shift;
  93.     my ($callpack, $callfile, $callline) = caller;
  94.     foreach (@_) {
  95.     $NPH++, next if $_ eq ':nph';
  96.     $PRIVATE_TEMPFILES++, next if $_ eq ':private_tempfiles';
  97.     foreach (&expand_tags($_)) {
  98.         tr/a-zA-Z0-9_//cd;  # don't allow weird function names
  99.         $EXPORT{$_}++;
  100.     }
  101.     }
  102.     my @packages = ($self,@{"$self\:\:ISA"});
  103.     foreach $sym (keys %EXPORT) {
  104.     my $pck;
  105.     my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
  106.     foreach $pck (@packages) {
  107.         if (defined(&{"$pck\:\:$sym"})) {
  108.         $def = $pck;
  109.         last;
  110.         }
  111.     }
  112.     *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
  113.     }
  114. }
  115.  
  116. sub expand_tags {
  117.     my($tag) = @_;
  118.     my(@r);
  119.     return ($tag) unless $EXPORT_TAGS{$tag};
  120.     foreach (@{$EXPORT_TAGS{$tag}}) {
  121.     push(@r,&expand_tags($_));
  122.     }
  123.     return @r;
  124. }
  125.  
  126. sub new {
  127.     my($class,$initializer) = @_;
  128.     my $self = {};
  129.     bless $self,ref $class || $class || $DefaultClass;
  130.     $CGI::DefaultClass->_reset_globals() if $MOD_PERL;
  131.     $initializer = to_filehandle($initializer) if $initializer;
  132.     $self->init($initializer);
  133.     return $self;
  134. }
  135.  
  136. sub DESTROY { }
  137.  
  138. sub param {
  139.     my($self,@p) = self_or_default(@_);
  140.     return $self->all_parameters unless @p;
  141.     my($name,$value,@other);
  142.  
  143.     if (@p > 1) {
  144.     ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
  145.     my(@values);
  146.  
  147.     if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
  148.         @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
  149.     } else {
  150.         foreach ($value,@other) {
  151.         push(@values,$_) if defined($_);
  152.         }
  153.     }
  154.     if (@values) {
  155.         $self->add_parameter($name);
  156.         $self->{$name}=[@values];
  157.     }
  158.     } else {
  159.     $name = $p[0];
  160.     }
  161.  
  162.     return () unless defined($name) && $self->{$name};
  163.     return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
  164. }
  165.  
  166. sub delete {
  167.     my($self,$name) = self_or_default(@_);
  168.     delete $self->{$name};
  169.     delete $self->{'.fieldnames'}->{$name};
  170.     @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
  171.     return wantarray ? () : undef;
  172. }
  173.  
  174. sub self_or_default {
  175.     return @_ if defined($_[0]) && !ref($_[0]) && ($_[0] eq 'CGI');
  176.     unless (defined($_[0]) && 
  177.         ref($_[0]) &&
  178.         (ref($_[0]) eq 'CGI' ||
  179.          eval "\$_[0]->isaCGI()")) { # optimize for the common case
  180.     $CGI::DefaultClass->_reset_globals() 
  181.         if defined($Q) && $MOD_PERL && $CGI::DefaultClass->_new_request();
  182.     $Q = $CGI::DefaultClass->new unless defined($Q);
  183.     unshift(@_,$Q);
  184.     }
  185.     return @_;
  186. }
  187.  
  188. sub _new_request {
  189.     return undef unless (defined(Apache->seqno()) or eval { require Apache });
  190.     if (Apache->seqno() != $SEQNO) {
  191.     $SEQNO = Apache->seqno();
  192.     return 1;
  193.     } else {
  194.     return undef;
  195.     }
  196. }
  197.  
  198. sub _reset_globals {
  199.     undef $Q;
  200.     undef @QUERY_PARAM;
  201. }
  202.  
  203. sub self_or_CGI {
  204.     local $^W=0;                # prevent a warning
  205.     if (defined($_[0]) &&
  206.     (substr(ref($_[0]),0,3) eq 'CGI' 
  207.      || eval "\$_[0]->isaCGI()")) {
  208.     return @_;
  209.     } else {
  210.     return ($DefaultClass,@_);
  211.     }
  212. }
  213.  
  214. sub isaCGI {
  215.     return 1;
  216. }
  217.  
  218. sub import_names {
  219.     my($self,$namespace) = self_or_default(@_);
  220.     $namespace = 'Q' unless defined($namespace);
  221.     die "Can't import names into 'main'\n"
  222.     if $namespace eq 'main';
  223.     my($param,@value,$var);
  224.     foreach $param ($self->param) {
  225.     ($var = $param)=~tr/a-zA-Z0-9_/_/c;
  226.     $var = "${namespace}::$var";
  227.     @value = $self->param($param);
  228.     @{$var} = @value;
  229.     ${$var} = $value[0];
  230.     }
  231. }
  232.  
  233. sub use_named_parameters {
  234.     my($self,$use_named) = self_or_default(@_);
  235.     return $self->{'.named'} unless defined ($use_named);
  236.  
  237.     return $self->{'.named'}=$use_named;
  238. }
  239.  
  240.  
  241.  
  242. sub init {
  243.     my($self,$initializer) = @_;
  244.     my($query_string,@lines);
  245.     my($meth) = '';
  246.  
  247.     if (defined(@QUERY_PARAM) && !defined($initializer)) {
  248.  
  249.     foreach (@QUERY_PARAM) {
  250.         $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
  251.     }
  252.     return;
  253.     }
  254.  
  255.     $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
  256.  
  257.   METHOD: {
  258.       if (defined($initializer)) {
  259.  
  260.       if (ref($initializer) && ref($initializer) eq 'HASH') {
  261.           foreach (keys %$initializer) {
  262.           $self->param('-name'=>$_,'-value'=>$initializer->{$_});
  263.           }
  264.           last METHOD;
  265.       }
  266.       
  267.       $initializer = $$initializer if ref($initializer);
  268.       if (defined(fileno($initializer))) {
  269.           while (<$initializer>) {
  270.           chomp;
  271.           last if /^=/;
  272.           push(@lines,$_);
  273.           }
  274.           if ("@lines" =~ /=/) {
  275.           $query_string=join("&",@lines);
  276.           } else {
  277.           $query_string=join("+",@lines);
  278.           }
  279.           last METHOD;
  280.       }
  281.       $query_string = $initializer;
  282.       last METHOD;
  283.       }
  284.       if ($meth=~/^(GET|HEAD)$/) {
  285.     $query_string = $ENV{'QUERY_STRING'};
  286.     last METHOD;
  287.     }
  288.     
  289.       if ($meth eq 'POST') {
  290.  
  291.       if (defined($ENV{'CONTENT_TYPE'}) 
  292.           && 
  293.           $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|) {
  294.           my($boundary) = $ENV{'CONTENT_TYPE'}=~/boundary=(\S+)/;
  295.           $self->read_multipart($boundary,$ENV{'CONTENT_LENGTH'});
  296.  
  297.       } else {
  298.  
  299.           $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0)
  300.           if $ENV{'CONTENT_LENGTH'} > 0;
  301.  
  302.       }
  303.       last METHOD;
  304.       }
  305.       
  306.       $query_string = &read_from_cmdline;
  307.   }
  308.     
  309.     if ($query_string) {
  310.     if ($query_string =~ /=/) {
  311.         $self->parse_params($query_string);
  312.     } else {
  313.         $self->add_parameter('keywords');
  314.         $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
  315.     }
  316.     }
  317.  
  318.     if ($self->param('.defaults')) {
  319.     undef %{$self};
  320.     }
  321.  
  322.     $self->{'.fieldnames'} = {};
  323.     foreach ($self->param('.cgifields')) {
  324.     $self->{'.fieldnames'}->{$_}++;
  325.     }
  326.     
  327.     $self->delete('.submit');
  328.     $self->delete('.cgifields');
  329.     $self->save_request unless $initializer;
  330.  
  331. }
  332.  
  333.  
  334.  
  335. sub to_filehandle {
  336.     my $string = shift;
  337.     if ($string && !ref($string)) {
  338.     my($package) = caller(1);
  339.     my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string"; 
  340.     return $tmp if defined(fileno($tmp));
  341.     }
  342.     return $string;
  343. }
  344.  
  345. sub new_MultipartBuffer {
  346.     my($self,$boundary,$length,$filehandle) = @_;
  347.     return MultipartBuffer->new($self,$boundary,$length,$filehandle);
  348. }
  349.  
  350. sub read_from_client {
  351.     my($self, $fh, $buff, $len, $offset) = @_;
  352.     local $^W=0;                # prevent a warning
  353.     return read($fh, $$buff, $len, $offset);
  354. }
  355.  
  356. sub binmode {
  357.     binmode($_[1]);
  358. }
  359.  
  360. sub put {
  361.     my($self,@p) = self_or_default(@_);
  362.     $self->print(@p);
  363. }
  364.  
  365. sub print {
  366.     shift;
  367.     CORE::print(@_);
  368. }
  369.  
  370. sub unescape {
  371.     my($todecode) = @_;
  372.     $todecode =~ tr/+/ /;       # pluses become spaces
  373.     $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
  374.     return $todecode;
  375. }
  376.  
  377. sub escape {
  378.     my($toencode) = @_;
  379.     $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
  380.     return $toencode;
  381. }
  382.  
  383. sub save_request {
  384.     my($self) = @_;
  385.     @QUERY_PARAM = $self->param; # save list of parameters
  386.     foreach (@QUERY_PARAM) {
  387.     $QUERY_PARAM{$_}=$self->{$_};
  388.     }
  389. }
  390.  
  391. sub parse_keywordlist {
  392.     my($self,$tosplit) = @_;
  393.     $tosplit = &unescape($tosplit); # unescape the keywords
  394.     $tosplit=~tr/+/ /;          # pluses to spaces
  395.     my(@keywords) = split(/\s+/,$tosplit);
  396.     return @keywords;
  397. }
  398.  
  399. sub parse_params {
  400.     my($self,$tosplit) = @_;
  401.     my(@pairs) = split('&',$tosplit);
  402.     my($param,$value);
  403.     foreach (@pairs) {
  404.     ($param,$value) = split('=');
  405.     $param = &unescape($param);
  406.     $value = &unescape($value);
  407.     $self->add_parameter($param);
  408.     push (@{$self->{$param}},$value);
  409.     }
  410. }
  411.  
  412. sub add_parameter {
  413.     my($self,$param)=@_;
  414.     push (@{$self->{'.parameters'}},$param) 
  415.     unless defined($self->{$param});
  416. }
  417.  
  418. sub all_parameters {
  419.     my $self = shift;
  420.     return () unless defined($self) && $self->{'.parameters'};
  421.     return () unless @{$self->{'.parameters'}};
  422.     return @{$self->{'.parameters'}};
  423. }
  424.  
  425. sub as_string {
  426.     &dump(@_);
  427. }
  428.  
  429. sub AUTOLOAD {
  430.     print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
  431.     my($func) = $AUTOLOAD;
  432.     my($pack,$func_name) = $func=~/(.+)::([^:]+)$/;
  433.     $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
  434.                 unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
  435.  
  436.     my($sub) = \%{"$pack\:\:SUBS"};
  437.     unless (%$sub) {
  438.     my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
  439.     eval "package $pack; $$auto";
  440.     die $@ if $@;
  441.     }
  442.     my($code) = $sub->{$func_name};
  443.  
  444.     $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
  445.     if (!$code) {
  446.     if ($EXPORT{':any'} || 
  447.         $EXPORT{$func_name} || 
  448.         (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
  449.         && $EXPORT_OK{$func_name}) {
  450.         $code = $sub->{'HTML_FUNC'};
  451.         $code=~s/func_name/$func_name/mg;
  452.     }
  453.     }
  454.     die "Undefined subroutine $AUTOLOAD\n" unless $code;
  455.     eval "package $pack; $code";
  456.     if ($@) {
  457.     $@ =~ s/ at .*\n//;
  458.     die $@;
  459.     }
  460.     goto &{"$pack\:\:$func_name"};
  461. }
  462.  
  463. sub rearrange {
  464.     my($self,$order,@param) = @_;
  465.     return () unless @param;
  466.     
  467.     return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-')
  468.     || $self->use_named_parameters;
  469.  
  470.     my $i;
  471.     for ($i=0;$i<@param;$i+=2) {
  472.     $param[$i]=~s/^\-//;     # get rid of initial - if present
  473.     $param[$i]=~tr/a-z/A-Z/; # parameters are upper case
  474.     }
  475.     
  476.     my(%param) = @param;                # convert into associative array
  477.     my(@return_array);
  478.     
  479.     my($key)='';
  480.     foreach $key (@$order) {
  481.     my($value);
  482.     if (ref($key) && ref($key) eq 'ARRAY') {
  483.         foreach (@$key) {
  484.         last if defined($value);
  485.         $value = $param{$_};
  486.         delete $param{$_};
  487.         }
  488.     } else {
  489.         $value = $param{$key};
  490.         delete $param{$key};
  491.     }
  492.     push(@return_array,$value);
  493.     }
  494.     push (@return_array,$self->make_attributes(\%param)) if %param;
  495.     return (@return_array);
  496. }
  497.  
  498. $AUTOLOADED_ROUTINES = '';      # get rid of -w warning
  499. $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
  500.  
  501. %SUBS = (
  502.  
  503. 'URL_ENCODED'=> <<'END_OF_FUNC',
  504. sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
  505. END_OF_FUNC
  506.  
  507. 'MULTIPART' => <<'END_OF_FUNC',
  508. sub MULTIPART {  'multipart/form-data'; }
  509. END_OF_FUNC
  510.  
  511. 'HTML_FUNC' => <<'END_OF_FUNC',
  512. sub func_name { 
  513.  
  514.     shift if $_[0] && 
  515.     (!ref($_[0]) && $_[0] eq $CGI::DefaultClass) ||
  516.         (ref($_[0]) &&
  517.          (substr(ref($_[0]),0,3) eq 'CGI' ||
  518.           eval "\$_[0]->isaCGI()"));
  519.  
  520.     my($attr) = '';
  521.     if (ref($_[0]) && ref($_[0]) eq 'HASH') {
  522.     my(@attr) = CGI::make_attributes('',shift);
  523.     $attr = " @attr" if @attr;
  524.     }
  525.     my($tag,$untag) = ("\U<func_name\E$attr>","\U</func_name>\E");
  526.     return $tag unless @_;
  527.     if (ref($_[0]) eq 'ARRAY') {
  528.     my(@r);
  529.     foreach (@{$_[0]}) {
  530.         push(@r,"$tag$_$untag");
  531.     }
  532.     return "@r";
  533.     } else {
  534.     return "$tag@_$untag";
  535.     }
  536. }
  537. END_OF_FUNC
  538.  
  539. 'keywords' => <<'END_OF_FUNC',
  540. sub keywords {
  541.     my($self,@values) = self_or_default(@_);
  542.     $self->{'keywords'}=[@values] if @values;
  543.     my(@result) = @{$self->{'keywords'}};
  544.     @result;
  545. }
  546. END_OF_FUNC
  547.  
  548. 'ReadParse' => <<'END_OF_FUNC',
  549. sub ReadParse {
  550.     local(*in);
  551.     if (@_) {
  552.     *in = $_[0];
  553.     } else {
  554.     my $pkg = caller();
  555.     *in=*{"${pkg}::in"};
  556.     }
  557.     tie(%in,CGI);
  558. }
  559. END_OF_FUNC
  560.  
  561. 'PrintHeader' => <<'END_OF_FUNC',
  562. sub PrintHeader {
  563.     my($self) = self_or_default(@_);
  564.     return $self->header();
  565. }
  566. END_OF_FUNC
  567.  
  568. 'HtmlTop' => <<'END_OF_FUNC',
  569. sub HtmlTop {
  570.     my($self,@p) = self_or_default(@_);
  571.     return $self->start_html(@p);
  572. }
  573. END_OF_FUNC
  574.  
  575. 'HtmlBot' => <<'END_OF_FUNC',
  576. sub HtmlBot {
  577.     my($self,@p) = self_or_default(@_);
  578.     return $self->end_html(@p);
  579. }
  580. END_OF_FUNC
  581.  
  582. 'SplitParam' => <<'END_OF_FUNC',
  583. sub SplitParam {
  584.     my ($param) = @_;
  585.     my (@params) = split ("\0", $param);
  586.     return (wantarray ? @params : $params[0]);
  587. }
  588. END_OF_FUNC
  589.  
  590. 'MethGet' => <<'END_OF_FUNC',
  591. sub MethGet {
  592.     return request_method() eq 'GET';
  593. }
  594. END_OF_FUNC
  595.  
  596. 'MethPost' => <<'END_OF_FUNC',
  597. sub MethPost {
  598.     return request_method() eq 'POST';
  599. }
  600. END_OF_FUNC
  601.  
  602. 'TIEHASH' => <<'END_OF_FUNC',
  603. sub TIEHASH { 
  604.     return new CGI;
  605. }
  606. END_OF_FUNC
  607.  
  608. 'STORE' => <<'END_OF_FUNC',
  609. sub STORE {
  610.     $_[0]->param($_[1],split("\0",$_[2]));
  611. }
  612. END_OF_FUNC
  613.  
  614. 'FETCH' => <<'END_OF_FUNC',
  615. sub FETCH {
  616.     return $_[0] if $_[1] eq 'CGI';
  617.     return undef unless defined $_[0]->param($_[1]);
  618.     return join("\0",$_[0]->param($_[1]));
  619. }
  620. END_OF_FUNC
  621.  
  622. 'FIRSTKEY' => <<'END_OF_FUNC',
  623. sub FIRSTKEY {
  624.     $_[0]->{'.iterator'}=0;
  625.     $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
  626. }
  627. END_OF_FUNC
  628.  
  629. 'NEXTKEY' => <<'END_OF_FUNC',
  630. sub NEXTKEY {
  631.     $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
  632. }
  633. END_OF_FUNC
  634.  
  635. 'EXISTS' => <<'END_OF_FUNC',
  636. sub EXISTS {
  637.     exists $_[0]->{$_[1]};
  638. }
  639. END_OF_FUNC
  640.  
  641. 'DELETE' => <<'END_OF_FUNC',
  642. sub DELETE {
  643.     $_[0]->delete($_[1]);
  644. }
  645. END_OF_FUNC
  646.  
  647. 'CLEAR' => <<'END_OF_FUNC',
  648. sub CLEAR {
  649.     %{$_[0]}=();
  650. }
  651. END_OF_FUNC
  652.  
  653. 'append' => <<'EOF',
  654. sub append {
  655.     my($self,@p) = @_;
  656.     my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
  657.     my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
  658.     if (@values) {
  659.     $self->add_parameter($name);
  660.     push(@{$self->{$name}},@values);
  661.     }
  662.     return $self->param($name);
  663. }
  664. EOF
  665.  
  666. 'delete_all' => <<'EOF',
  667. sub delete_all {
  668.     my($self) = self_or_default(@_);
  669.     undef %{$self};
  670. }
  671. EOF
  672.  
  673. 'autoEscape' => <<'END_OF_FUNC',
  674. sub autoEscape {
  675.     my($self,$escape) = self_or_default(@_);
  676.     $self->{'dontescape'}=!$escape;
  677. }
  678. END_OF_FUNC
  679.  
  680.  
  681. 'version' => <<'END_OF_FUNC',
  682. sub version {
  683.     return $VERSION;
  684. }
  685. END_OF_FUNC
  686.  
  687. 'make_attributes' => <<'END_OF_FUNC',
  688. sub make_attributes {
  689.     my($self,$attr) = @_;
  690.     return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
  691.     my(@att);
  692.     foreach (keys %{$attr}) {
  693.     my($key) = $_;
  694.     $key=~s/^\-//;     # get rid of initial - if present
  695.     $key=~tr/a-z/A-Z/; # parameters are upper case
  696.     push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/);
  697.     }
  698.     return @att;
  699. }
  700. END_OF_FUNC
  701.  
  702. 'dump' => <<'END_OF_FUNC',
  703. sub dump {
  704.     my($self) = self_or_default(@_);
  705.     my($param,$value,@result);
  706.     return '<UL></UL>' unless $self->param;
  707.     push(@result,"<UL>");
  708.     foreach $param ($self->param) {
  709.     my($name)=$self->escapeHTML($param);
  710.     push(@result,"<LI><STRONG>$param</STRONG>");
  711.     push(@result,"<UL>");
  712.     foreach $value ($self->param($param)) {
  713.         $value = $self->escapeHTML($value);
  714.         push(@result,"<LI>$value");
  715.     }
  716.     push(@result,"</UL>");
  717.     }
  718.     push(@result,"</UL>\n");
  719.     return join("\n",@result);
  720. }
  721. END_OF_FUNC
  722.  
  723.  
  724. 'save' => <<'END_OF_FUNC',
  725. sub save {
  726.     my($self,$filehandle) = self_or_default(@_);
  727.     my($param);
  728.     my($package) = caller;
  729.     $filehandle = to_filehandle($filehandle);
  730.     foreach $param ($self->param) {
  731.     my($escaped_param) = &escape($param);
  732.     my($value);
  733.     foreach $value ($self->param($param)) {
  734.         print $filehandle "$escaped_param=",escape($value),"\n";
  735.     }
  736.     }
  737.     print $filehandle "=\n";    # end of record
  738. }
  739. END_OF_FUNC
  740.  
  741.  
  742. 'header' => <<'END_OF_FUNC',
  743. sub header {
  744.     my($self,@p) = self_or_default(@_);
  745.     my(@header);
  746.  
  747.     my($type,$status,$cookie,$target,$expires,$nph,@other) = 
  748.     $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
  749.  
  750.     foreach (@other) {
  751.     next unless my($header,$value) = /([^\s=]+)=(.+)/;
  752.     substr($header,1,1000)=~tr/A-Z/a-z/;
  753.     ($value)=$value=~/^"(.*)"$/;
  754.     $_ = "$header: $value";
  755.     }
  756.  
  757.     $type = $type || 'text/html';
  758.  
  759.     push(@header,'HTTP/1.0 ' . ($status || '200 OK')) if $nph || $NPH;
  760.     push(@header,"Status: $status") if $status;
  761.     push(@header,"Window-target: $target") if $target;
  762.     if ($cookie) {
  763.     my(@cookie) = ref($cookie) ? @{$cookie} : $cookie;
  764.     foreach (@cookie) {
  765.         push(@header,"Set-cookie: $_");
  766.     }
  767.     }
  768.     push(@header,"Expires: " . &date(&expire_calc($expires),'http'))
  769.     if $expires;
  770.     push(@header,"Date: " . &date(&expire_calc(0),'http')) if $expires || $cookie;
  771.     push(@header,"Pragma: no-cache") if $self->cache();
  772.     push(@header,@other);
  773.     push(@header,"Content-type: $type");
  774.  
  775.     my $header = join($CRLF,@header);
  776.     return $header . "${CRLF}${CRLF}";
  777. }
  778. END_OF_FUNC
  779.  
  780.  
  781. 'cache' => <<'END_OF_FUNC',
  782. sub cache {
  783.     my($self,$new_value) = self_or_default(@_);
  784.     $new_value = '' unless $new_value;
  785.     if ($new_value ne '') {
  786.     $self->{'cache'} = $new_value;
  787.     }
  788.     return $self->{'cache'};
  789. }
  790. END_OF_FUNC
  791.  
  792.  
  793. 'redirect' => <<'END_OF_FUNC',
  794. sub redirect {
  795.     my($self,@p) = self_or_default(@_);
  796.     my($url,$target,$cookie,$nph,@other) = $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p);
  797.     $url = $url || $self->self_url;
  798.     my(@o);
  799.     foreach (@other) { push(@o,split("=")); }
  800.     if($MOD_PERL or exists $self->{'.req'}) {
  801.     my $r = $self->{'.req'} || Apache->request;
  802.     $r->header_out(Location => $url);
  803.     $r->err_header_out(Location => $url);
  804.     $r->status(302);
  805.     return;
  806.     }
  807.     push(@o,
  808.      '-Status'=>'302 Found',
  809.      '-Location'=>$url,
  810.      '-URI'=>$url,
  811.      '-nph'=>($nph||$NPH));
  812.     push(@o,'-Target'=>$target) if $target;
  813.     push(@o,'-Cookie'=>$cookie) if $cookie;
  814.     return $self->header(@o);
  815. }
  816. END_OF_FUNC
  817.  
  818.  
  819. 'start_html' => <<'END_OF_FUNC',
  820. sub start_html {
  821.     my($self,@p) = &self_or_default(@_);
  822.     my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,@other) = 
  823.     $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE],@p);
  824.  
  825.     $title = $self->escapeHTML($title || 'Untitled Document');
  826.     $author = $self->escapeHTML($author);
  827.     my(@result);
  828.     push(@result,'<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">');
  829.     push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
  830.     push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if $author;
  831.  
  832.     if ($base || $xbase || $target) {
  833.     my $href = $xbase || $self->url();
  834.     my $t = $target ? qq/ TARGET="$target"/ : '';
  835.     push(@result,qq/<BASE HREF="$href"$t>/);
  836.     }
  837.  
  838.     if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
  839.     foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
  840.     }
  841.  
  842.     push(@result,ref($head) ? @$head : $head) if $head;
  843.  
  844.     if ($style) {
  845.     if (ref($style)) {
  846.         my($src,$code,@other) =
  847.         $self->rearrange([SRC,CODE],
  848.                  '-foo'=>'bar',    # a trick to allow the '-' to be omitted
  849.                  ref($style) eq 'ARRAY' ? @$style : %$style);
  850.         push(@result,qq/<LINK REL="stylesheet" HREF="$src">/) if $src;
  851.         push(@result,style($code)) if $code;
  852.     } else {
  853.         push(@result,style($style))
  854.     }
  855.     }
  856.  
  857.     if ($script) {
  858.     my($src,$code,$language);
  859.     if (ref($script)) { # script is a hash
  860.         ($src,$code,$language) =
  861.         $self->rearrange([SRC,CODE,LANGUAGE],
  862.                  '-foo'=>'bar',    # a trick to allow the '-' to be omitted
  863.                  ref($style) eq 'ARRAY' ? @$script : %$script);
  864.     
  865.     } else {
  866.         ($src,$code,$language) = ('',$script,'JavaScript');
  867.     }
  868.     my(@satts);
  869.     push(@satts,'src'=>$src) if $src;
  870.     push(@satts,'language'=>$language || 'JavaScript');
  871.     $code = "<!-- Hide script\n$code\n// End script hiding -->"
  872.         if $code && $language=~/javascript/i;
  873.     $code = "<!-- Hide script\n$code\n\# End script hiding -->"
  874.         if $code && $language=~/perl/i;
  875.     push(@result,script({@satts},$code));
  876.     }
  877.  
  878.     push(@result,<<END) if $noscript;
  879. <NOSCRIPT>
  880. $noscript
  881. </NOSCRIPT>
  882. END
  883.     ;
  884.     my($other) = @other ? " @other" : '';
  885.     push(@result,"</HEAD><BODY$other>");
  886.     return join("\n",@result);
  887. }
  888. END_OF_FUNC
  889.  
  890.  
  891. 'end_html' => <<'END_OF_FUNC',
  892. sub end_html {
  893.     return "</BODY></HTML>";
  894. }
  895. END_OF_FUNC
  896.  
  897.  
  898.  
  899. 'isindex' => <<'END_OF_FUNC',
  900. sub isindex {
  901.     my($self,@p) = self_or_default(@_);
  902.     my($action,@other) = $self->rearrange([ACTION],@p);
  903.     $action = qq/ACTION="$action"/ if $action;
  904.     my($other) = @other ? " @other" : '';
  905.     return "<ISINDEX $action$other>";
  906. }
  907. END_OF_FUNC
  908.  
  909.  
  910. 'startform' => <<'END_OF_FUNC',
  911. sub startform {
  912.     my($self,@p) = self_or_default(@_);
  913.  
  914.     my($method,$action,$enctype,@other) = 
  915.     $self->rearrange([METHOD,ACTION,ENCTYPE],@p);
  916.  
  917.     $method = $method || 'POST';
  918.     $enctype = $enctype || &URL_ENCODED;
  919.     $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
  920.     'ACTION="'.$self->script_name.'"' : '';
  921.     my($other) = @other ? " @other" : '';
  922.     $self->{'.parametersToAdd'}={};
  923.     return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
  924. }
  925. END_OF_FUNC
  926.  
  927.  
  928. 'start_form' => <<'END_OF_FUNC',
  929. sub start_form {
  930.     &startform;
  931. }
  932. END_OF_FUNC
  933.  
  934.  
  935. 'start_multipart_form' => <<'END_OF_FUNC',
  936. sub start_multipart_form {
  937.     my($self,@p) = self_or_default(@_);
  938.     if ($self->use_named_parameters || 
  939.     (defined($param[0]) && substr($param[0],0,1) eq '-')) {
  940.     my(%p) = @p;
  941.     $p{'-enctype'}=&MULTIPART;
  942.     return $self->startform(%p);
  943.     } else {
  944.     my($method,$action,@other) = 
  945.         $self->rearrange([METHOD,ACTION],@p);
  946.     return $self->startform($method,$action,&MULTIPART,@other);
  947.     }
  948. }
  949. END_OF_FUNC
  950.  
  951.  
  952. 'endform' => <<'END_OF_FUNC',
  953. sub endform {
  954.     my($self,@p) = self_or_default(@_);    
  955.     return ($self->get_fields,"</FORM>");
  956. }
  957. END_OF_FUNC
  958.  
  959.  
  960. 'end_form' => <<'END_OF_FUNC',
  961. sub end_form {
  962.     &endform;
  963. }
  964. END_OF_FUNC
  965.  
  966.  
  967. 'textfield' => <<'END_OF_FUNC',
  968. sub textfield {
  969.     my($self,@p) = self_or_default(@_);
  970.     my($name,$default,$size,$maxlength,$override,@other) = 
  971.     $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
  972.  
  973.     my $current = $override ? $default : 
  974.     (defined($self->param($name)) ? $self->param($name) : $default);
  975.  
  976.     $current = defined($current) ? $self->escapeHTML($current) : '';
  977.     $name = defined($name) ? $self->escapeHTML($name) : '';
  978.     my($s) = defined($size) ? qq/ SIZE=$size/ : '';
  979.     my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
  980.     my($other) = @other ? " @other" : '';    
  981.     return qq/<INPUT TYPE="text" NAME="$name" VALUE="$current"$s$m$other>/;
  982. }
  983. END_OF_FUNC
  984.  
  985.  
  986. 'filefield' => <<'END_OF_FUNC',
  987. sub filefield {
  988.     my($self,@p) = self_or_default(@_);
  989.  
  990.     my($name,$default,$size,$maxlength,$override,@other) = 
  991.     $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
  992.  
  993.     $current = $override ? $default :
  994.     (defined($self->param($name)) ? $self->param($name) : $default);
  995.  
  996.     $name = defined($name) ? $self->escapeHTML($name) : '';
  997.     my($s) = defined($size) ? qq/ SIZE=$size/ : '';
  998.     my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
  999.     $current = defined($current) ? $self->escapeHTML($current) : '';
  1000.     $other = ' ' . join(" ",@other);
  1001.     return qq/<INPUT TYPE="file" NAME="$name" VALUE="$current"$s$m$other>/;
  1002. }
  1003. END_OF_FUNC
  1004.  
  1005.  
  1006. 'password_field' => <<'END_OF_FUNC',
  1007. sub password_field {
  1008.     my ($self,@p) = self_or_default(@_);
  1009.  
  1010.     my($name,$default,$size,$maxlength,$override,@other) = 
  1011.     $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
  1012.  
  1013.     my($current) =  $override ? $default :
  1014.     (defined($self->param($name)) ? $self->param($name) : $default);
  1015.  
  1016.     $name = defined($name) ? $self->escapeHTML($name) : '';
  1017.     $current = defined($current) ? $self->escapeHTML($current) : '';
  1018.     my($s) = defined($size) ? qq/ SIZE=$size/ : '';
  1019.     my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
  1020.     my($other) = @other ? " @other" : '';
  1021.     return qq/<INPUT TYPE="password" NAME="$name" VALUE="$current"$s$m$other>/;
  1022. }
  1023. END_OF_FUNC
  1024.  
  1025.  
  1026. 'textarea' => <<'END_OF_FUNC',
  1027. sub textarea {
  1028.     my($self,@p) = self_or_default(@_);
  1029.     
  1030.     my($name,$default,$rows,$cols,$override,@other) =
  1031.     $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
  1032.  
  1033.     my($current)= $override ? $default :
  1034.     (defined($self->param($name)) ? $self->param($name) : $default);
  1035.  
  1036.     $name = defined($name) ? $self->escapeHTML($name) : '';
  1037.     $current = defined($current) ? $self->escapeHTML($current) : '';
  1038.     my($r) = $rows ? " ROWS=$rows" : '';
  1039.     my($c) = $cols ? " COLS=$cols" : '';
  1040.     my($other) = @other ? " @other" : '';
  1041.     return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
  1042. }
  1043. END_OF_FUNC
  1044.  
  1045.  
  1046. 'button' => <<'END_OF_FUNC',
  1047. sub button {
  1048.     my($self,@p) = self_or_default(@_);
  1049.  
  1050.     my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
  1051.                              [ONCLICK,SCRIPT]],@p);
  1052.  
  1053.     $label=$self->escapeHTML($label);
  1054.     $value=$self->escapeHTML($value);
  1055.     $script=$self->escapeHTML($script);
  1056.  
  1057.     my($name) = '';
  1058.     $name = qq/ NAME="$label"/ if $label;
  1059.     $value = $value || $label;
  1060.     my($val) = '';
  1061.     $val = qq/ VALUE="$value"/ if $value;
  1062.     $script = qq/ ONCLICK="$script"/ if $script;
  1063.     my($other) = @other ? " @other" : '';
  1064.     return qq/<INPUT TYPE="button"$name$val$script$other>/;
  1065. }
  1066. END_OF_FUNC
  1067.  
  1068.  
  1069. 'submit' => <<'END_OF_FUNC',
  1070. sub submit {
  1071.     my($self,@p) = self_or_default(@_);
  1072.  
  1073.     my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p);
  1074.  
  1075.     $label=$self->escapeHTML($label);
  1076.     $value=$self->escapeHTML($value);
  1077.  
  1078.     my($name) = ' NAME=".submit"';
  1079.     $name = qq/ NAME="$label"/ if $label;
  1080.     $value = $value || $label;
  1081.     my($val) = '';
  1082.     $val = qq/ VALUE="$value"/ if defined($value);
  1083.     my($other) = @other ? " @other" : '';
  1084.     return qq/<INPUT TYPE="submit"$name$val$other>/;
  1085. }
  1086. END_OF_FUNC
  1087.  
  1088.  
  1089. 'reset' => <<'END_OF_FUNC',
  1090. sub reset {
  1091.     my($self,@p) = self_or_default(@_);
  1092.     my($label,@other) = $self->rearrange([NAME],@p);
  1093.     $label=$self->escapeHTML($label);
  1094.     my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
  1095.     my($other) = @other ? " @other" : '';
  1096.     return qq/<INPUT TYPE="reset"$value$other>/;
  1097. }
  1098. END_OF_FUNC
  1099.  
  1100.  
  1101. 'defaults' => <<'END_OF_FUNC',
  1102. sub defaults {
  1103.     my($self,@p) = self_or_default(@_);
  1104.  
  1105.     my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
  1106.  
  1107.     $label=$self->escapeHTML($label);
  1108.     $label = $label || "Defaults";
  1109.     my($value) = qq/ VALUE="$label"/;
  1110.     my($other) = @other ? " @other" : '';
  1111.     return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
  1112. }
  1113. END_OF_FUNC
  1114.  
  1115.  
  1116. 'checkbox' => <<'END_OF_FUNC',
  1117. sub checkbox {
  1118.     my($self,@p) = self_or_default(@_);
  1119.  
  1120.     my($name,$checked,$value,$label,$override,@other) = 
  1121.     $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
  1122.     
  1123.     if (!$override && defined($self->param($name))) {
  1124.     $value = $self->param($name) unless defined $value;
  1125.     $checked = $self->param($name) eq $value ? ' CHECKED' : '';
  1126.     } else {
  1127.     $checked = $checked ? ' CHECKED' : '';
  1128.     $value = defined $value ? $value : 'on';
  1129.     }
  1130.     my($the_label) = defined $label ? $label : $name;
  1131.     $name = $self->escapeHTML($name);
  1132.     $value = $self->escapeHTML($value);
  1133.     $the_label = $self->escapeHTML($the_label);
  1134.     my($other) = @other ? " @other" : '';
  1135.     $self->register_parameter($name);
  1136.     return <<END;
  1137. <INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label
  1138. END
  1139. }
  1140. END_OF_FUNC
  1141.  
  1142.  
  1143. 'checkbox_group' => <<'END_OF_FUNC',
  1144. sub checkbox_group {
  1145.     my($self,@p) = self_or_default(@_);
  1146.  
  1147.     my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
  1148.        $rowheaders,$colheaders,$override,$nolabels,@other) =
  1149.     $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
  1150.               LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
  1151.               ROWHEADERS,COLHEADERS,
  1152.               [OVERRIDE,FORCE],NOLABELS],@p);
  1153.  
  1154.     my($checked,$break,$result,$label);
  1155.  
  1156.     my(%checked) = $self->previous_or_default($name,$defaults,$override);
  1157.  
  1158.     $break = $linebreak ? "<BR>" : '';
  1159.     $name=$self->escapeHTML($name);
  1160.  
  1161.     my(@elements);
  1162.     my(@values) = $values ? @$values : $self->param($name);
  1163.     my($other) = @other ? " @other" : '';
  1164.     foreach (@values) {
  1165.     $checked = $checked{$_} ? ' CHECKED' : '';
  1166.     $label = '';
  1167.     unless (defined($nolabels) && $nolabels) {
  1168.         $label = $_;
  1169.         $label = $labels->{$_} if defined($labels) && $labels->{$_};
  1170.         $label = $self->escapeHTML($label);
  1171.     }
  1172.     $_ = $self->escapeHTML($_);
  1173.     push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label} ${break}/);
  1174.     }
  1175.     $self->register_parameter($name);
  1176.     return wantarray ? @elements : join('',@elements) unless $columns;
  1177.     return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
  1178. }
  1179. END_OF_FUNC
  1180.  
  1181.  
  1182. 'escapeHTML' => <<'END_OF_FUNC',
  1183. sub escapeHTML {
  1184.     my($self,$toencode) = @_;
  1185.     return undef unless defined($toencode);
  1186.     return $toencode if $self->{'dontescape'};
  1187.     $toencode=~s/&/&/g;
  1188.     $toencode=~s/\"/"/g;
  1189.     $toencode=~s/>/>/g;
  1190.     $toencode=~s/</</g;
  1191.     return $toencode;
  1192. }
  1193. END_OF_FUNC
  1194.  
  1195.  
  1196. '_tableize' => <<'END_OF_FUNC',
  1197. sub _tableize {
  1198.     my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
  1199.     my($result);
  1200.  
  1201.     $rows = int(0.99 + @elements/$columns) unless $rows;
  1202.     $result = "<TABLE>";
  1203.     my($row,$column);
  1204.     unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
  1205.     $result .= "<TR>" if @{$colheaders};
  1206.     foreach (@{$colheaders}) {
  1207.     $result .= "<TH>$_</TH>";
  1208.     }
  1209.     for ($row=0;$row<$rows;$row++) {
  1210.     $result .= "<TR>";
  1211.     $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
  1212.     for ($column=0;$column<$columns;$column++) {
  1213.         $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>";
  1214.     }
  1215.     $result .= "</TR>";
  1216.     }
  1217.     $result .= "</TABLE>";
  1218.     return $result;
  1219. }
  1220. END_OF_FUNC
  1221.  
  1222.  
  1223. 'radio_group' => <<'END_OF_FUNC',
  1224. sub radio_group {
  1225.     my($self,@p) = self_or_default(@_);
  1226.  
  1227.     my($name,$values,$default,$linebreak,$labels,
  1228.        $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
  1229.     $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
  1230.               ROWS,[COLUMNS,COLS],
  1231.               ROWHEADERS,COLHEADERS,
  1232.               [OVERRIDE,FORCE],NOLABELS],@p);
  1233.     my($result,$checked);
  1234.  
  1235.     if (!$override && defined($self->param($name))) {
  1236.     $checked = $self->param($name);
  1237.     } else {
  1238.     $checked = $default;
  1239.     }
  1240.     $checked = $values->[0] unless $checked;
  1241.     $name=$self->escapeHTML($name);
  1242.  
  1243.     my(@elements);
  1244.     my(@values) = $values ? @$values : $self->param($name);
  1245.     my($other) = @other ? " @other" : '';
  1246.     foreach (@values) {
  1247.     my($checkit) = $checked eq $_ ? ' CHECKED' : '';
  1248.     my($break) = $linebreak ? '<BR>' : '';
  1249.     my($label)='';
  1250.     unless (defined($nolabels) && $nolabels) {
  1251.         $label = $_;
  1252.         $label = $labels->{$_} if defined($labels) && $labels->{$_};
  1253.         $label = $self->escapeHTML($label);
  1254.     }
  1255.     $_=$self->escapeHTML($_);
  1256.     push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label} ${break}/);
  1257.     }
  1258.     $self->register_parameter($name);
  1259.     return wantarray ? @elements : join('',@elements) unless $columns;
  1260.     return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
  1261. }
  1262. END_OF_FUNC
  1263.  
  1264.  
  1265. 'popup_menu' => <<'END_OF_FUNC',
  1266. sub popup_menu {
  1267.     my($self,@p) = self_or_default(@_);
  1268.  
  1269.     my($name,$values,$default,$labels,$override,@other) =
  1270.     $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
  1271.     my($result,$selected);
  1272.  
  1273.     if (!$override && defined($self->param($name))) {
  1274.     $selected = $self->param($name);
  1275.     } else {
  1276.     $selected = $default;
  1277.     }
  1278.     $name=$self->escapeHTML($name);
  1279.     my($other) = @other ? " @other" : '';
  1280.  
  1281.     my(@values) = $values ? @$values : $self->param($name);
  1282.     $result = qq/<SELECT NAME="$name"$other>\n/;
  1283.     foreach (@values) {
  1284.     my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
  1285.     my($label) = $_;
  1286.     $label = $labels->{$_} if defined($labels) && $labels->{$_};
  1287.     my($value) = $self->escapeHTML($_);
  1288.     $label=$self->escapeHTML($label);
  1289.     $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
  1290.     }
  1291.  
  1292.     $result .= "</SELECT>\n";
  1293.     return $result;
  1294. }
  1295. END_OF_FUNC
  1296.  
  1297.  
  1298. 'scrolling_list' => <<'END_OF_FUNC',
  1299. sub scrolling_list {
  1300.     my($self,@p) = self_or_default(@_);
  1301.     my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
  1302.     = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
  1303.                 SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
  1304.  
  1305.     my($result);
  1306.     my(@values) = $values ? @$values : $self->param($name);
  1307.     $size = $size || scalar(@values);
  1308.  
  1309.     my(%selected) = $self->previous_or_default($name,$defaults,$override);
  1310.     my($is_multiple) = $multiple ? ' MULTIPLE' : '';
  1311.     my($has_size) = $size ? " SIZE=$size" : '';
  1312.     my($other) = @other ? " @other" : '';
  1313.  
  1314.     $name=$self->escapeHTML($name);
  1315.     $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
  1316.     foreach (@values) {
  1317.     my($selectit) = $selected{$_} ? 'SELECTED' : '';
  1318.     my($label) = $_;
  1319.     $label = $labels->{$_} if defined($labels) && $labels->{$_};
  1320.     $label=$self->escapeHTML($label);
  1321.     my($value)=$self->escapeHTML($_);
  1322.     $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
  1323.     }
  1324.     $result .= "</SELECT>\n";
  1325.     $self->register_parameter($name);
  1326.     return $result;
  1327. }
  1328. END_OF_FUNC
  1329.  
  1330.  
  1331. 'hidden' => <<'END_OF_FUNC',
  1332. sub hidden {
  1333.     my($self,@p) = self_or_default(@_);
  1334.  
  1335.     my(@result,@value);
  1336.     my($name,$default,$override,@other) = 
  1337.     $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
  1338.  
  1339.     my $do_override = 0;
  1340.     if ( substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
  1341.     @value = ref($default) ? @{$default} : $default;
  1342.     $do_override = $override;
  1343.     } else {
  1344.     foreach ($default,$override,@other) {
  1345.         push(@value,$_) if defined($_);
  1346.     }
  1347.     }
  1348.  
  1349.     my @prev = $self->param($name);
  1350.     @value = @prev if !$do_override && @prev;
  1351.  
  1352.     $name=$self->escapeHTML($name);
  1353.     foreach (@value) {
  1354.     $_=$self->escapeHTML($_);
  1355.     push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
  1356.     }
  1357.     return wantarray ? @result : join('',@result);
  1358. }
  1359. END_OF_FUNC
  1360.  
  1361.  
  1362. 'image_button' => <<'END_OF_FUNC',
  1363. sub image_button {
  1364.     my($self,@p) = self_or_default(@_);
  1365.  
  1366.     my($name,$src,$alignment,@other) =
  1367.     $self->rearrange([NAME,SRC,ALIGN],@p);
  1368.  
  1369.     my($align) = $alignment ? " ALIGN=\U$alignment" : '';
  1370.     my($other) = @other ? " @other" : '';
  1371.     $name=$self->escapeHTML($name);
  1372.     return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/;
  1373. }
  1374. END_OF_FUNC
  1375.  
  1376.  
  1377. 'self_url' => <<'END_OF_FUNC',
  1378. sub self_url {
  1379.     my($self) = self_or_default(@_);
  1380.     my($query_string) = $self->query_string;
  1381.     my $protocol = $self->protocol();
  1382.     my $name = "$protocol://" . $self->server_name;
  1383.     $name .= ":" . $self->server_port
  1384.     unless $self->server_port == 80;
  1385.     $name .= $self->script_name;
  1386.     $name .= $self->path_info if $self->path_info;
  1387.     return $name unless $query_string;
  1388.     return "$name?$query_string";
  1389. }
  1390. END_OF_FUNC
  1391.  
  1392.  
  1393. 'state' => <<'END_OF_FUNC',
  1394. sub state {
  1395.     &self_url;
  1396. }
  1397. END_OF_FUNC
  1398.  
  1399.  
  1400. 'url' => <<'END_OF_FUNC',
  1401. sub url {
  1402.     my($self) = self_or_default(@_);
  1403.     my $protocol = $self->protocol();
  1404.     my $name = "$protocol://" . $self->server_name;
  1405.     $name .= ":" . $self->server_port
  1406.     unless $self->server_port == 80;
  1407.     $name .= $self->script_name;
  1408.     return $name;
  1409. }
  1410.  
  1411. END_OF_FUNC
  1412.  
  1413. 'cookie' => <<'END_OF_FUNC',
  1414. sub cookie {
  1415.     my($self,@p) = self_or_default(@_);
  1416.     my($name,$value,$path,$domain,$secure,$expires) =
  1417.     $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
  1418.  
  1419.  
  1420.     unless (defined($value)) {
  1421.     unless ($self->{'.cookies'}) {
  1422.         my(@pairs) = split("; ",$self->raw_cookie);
  1423.         foreach (@pairs) {
  1424.         my($key,$value) = split("=");
  1425.         my(@values) = map unescape($_),split('&',$value);
  1426.         $self->{'.cookies'}->{unescape($key)} = [@values];
  1427.         }
  1428.     }
  1429.  
  1430.     return () unless $self->{'.cookies'};
  1431.     return wantarray ? @{$self->{'.cookies'}->{$name}} : $self->{'.cookies'}->{$name}->[0]
  1432.         if defined($name) && $name ne '';
  1433.     return keys %{$self->{'.cookies'}};
  1434.     }
  1435.     my(@values);
  1436.  
  1437.     if (ref($value)) {
  1438.     if (ref($value) eq 'ARRAY') {
  1439.         @values = @$value;
  1440.     } elsif (ref($value) eq 'HASH') {
  1441.         @values = %$value;
  1442.     }
  1443.     } else {
  1444.     @values = ($value);
  1445.     }
  1446.     @values = map escape($_),@values;
  1447.  
  1448.     ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $path;
  1449.  
  1450.     my(@constant_values);
  1451.     push(@constant_values,"domain=$domain") if $domain;
  1452.     push(@constant_values,"path=$path") if $path;
  1453.     push(@constant_values,"expires=".&date(&expire_calc($expires),'cookie'))
  1454.     if $expires;
  1455.     push(@constant_values,'secure') if $secure;
  1456.  
  1457.     my($key) = &escape($name);
  1458.     my($cookie) = join("=",$key,join("&",@values));
  1459.     return join("; ",$cookie,@constant_values);
  1460. }
  1461. END_OF_FUNC
  1462.  
  1463.  
  1464. 'expire_calc' => <<'END_OF_FUNC',
  1465. sub expire_calc {
  1466.     my($time) = @_;
  1467.     my(%mult) = ('s'=>1,
  1468.                  'm'=>60,
  1469.                  'h'=>60*60,
  1470.                  'd'=>60*60*24,
  1471.                  'M'=>60*60*24*30,
  1472.                  'y'=>60*60*24*365);
  1473.     my($offset);
  1474.     if (!$time || ($time eq 'now')) {
  1475.         $offset = 0;
  1476.     } elsif ($time=~/^([+-]?\d+)([mhdMy]?)/) {
  1477.         $offset = ($mult{$2} || 1)*$1;
  1478.     } else {
  1479.         return $time;
  1480.     }
  1481.     return (time+$offset);
  1482. }
  1483. END_OF_FUNC
  1484.  
  1485. 'date' => <<'END_OF_FUNC',
  1486. sub date {
  1487.     my($time,$format) = @_;
  1488.     my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
  1489.     my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
  1490.  
  1491.     if ("$time" =~ m/^[^0-9]/o) {
  1492.         return $time;
  1493.     }
  1494.  
  1495.     my($sc) = ' ';
  1496.     $sc = '-' if $format eq "cookie";
  1497.     my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
  1498.     $year += 1900;
  1499.     return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
  1500.                    $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
  1501. }
  1502. END_OF_FUNC
  1503.  
  1504.  
  1505. 'path_info' => <<'END_OF_FUNC',
  1506. sub path_info {
  1507.     return $ENV{'PATH_INFO'};
  1508. }
  1509. END_OF_FUNC
  1510.  
  1511.  
  1512. 'request_method' => <<'END_OF_FUNC',
  1513. sub request_method {
  1514.     return $ENV{'REQUEST_METHOD'};
  1515. }
  1516. END_OF_FUNC
  1517.  
  1518. 'path_translated' => <<'END_OF_FUNC',
  1519. sub path_translated {
  1520.     return $ENV{'PATH_TRANSLATED'};
  1521. }
  1522. END_OF_FUNC
  1523.  
  1524.  
  1525. 'query_string' => <<'END_OF_FUNC',
  1526. sub query_string {
  1527.     my($self) = self_or_default(@_);
  1528.     my($param,$value,@pairs);
  1529.     foreach $param ($self->param) {
  1530.     my($eparam) = &escape($param);
  1531.     foreach $value ($self->param($param)) {
  1532.         $value = &escape($value);
  1533.         push(@pairs,"$eparam=$value");
  1534.     }
  1535.     }
  1536.     return join("&",@pairs);
  1537. }
  1538. END_OF_FUNC
  1539.  
  1540.  
  1541. 'accept' => <<'END_OF_FUNC',
  1542. sub accept {
  1543.     my($self,$search) = self_or_CGI(@_);
  1544.     my(%prefs,$type,$pref,$pat);
  1545.     
  1546.     my(@accept) = split(',',$self->http('accept'));
  1547.  
  1548.     foreach (@accept) {
  1549.     ($pref) = /q=(\d\.\d+|\d+)/;
  1550.     ($type) = m#(\S+/[^;]+)#;
  1551.     next unless $type;
  1552.     $prefs{$type}=$pref || 1;
  1553.     }
  1554.  
  1555.     return keys %prefs unless $search;
  1556.     
  1557.  
  1558.     return $prefs{$search} if $prefs{$search};
  1559.  
  1560.     foreach (keys %prefs) {
  1561.     next unless /\*/;       # not a pattern match
  1562.     ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
  1563.     $pat =~ s/\*/.*/g; # turn it into a pattern
  1564.     return $prefs{$_} if $search=~/$pat/;
  1565.     }
  1566. }
  1567. END_OF_FUNC
  1568.  
  1569.  
  1570. 'user_agent' => <<'END_OF_FUNC',
  1571. sub user_agent {
  1572.     my($self,$match)=self_or_CGI(@_);
  1573.     return $self->http('user_agent') unless $match;
  1574.     return $self->http('user_agent') =~ /$match/i;
  1575. }
  1576. END_OF_FUNC
  1577.  
  1578.  
  1579. 'raw_cookie' => <<'END_OF_FUNC',
  1580. sub raw_cookie {
  1581.     my($self) = self_or_CGI(@_);
  1582.     return $self->http('cookie') || $ENV{'COOKIE'} || '';
  1583. }
  1584. END_OF_FUNC
  1585.  
  1586. 'virtual_host' => <<'END_OF_FUNC',
  1587. sub virtual_host {
  1588.     return http('host') || server_name();
  1589. }
  1590. END_OF_FUNC
  1591.  
  1592. 'remote_host' => <<'END_OF_FUNC',
  1593. sub remote_host {
  1594.     return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} 
  1595.     || 'localhost';
  1596. }
  1597. END_OF_FUNC
  1598.  
  1599.  
  1600. 'remote_addr' => <<'END_OF_FUNC',
  1601. sub remote_addr {
  1602.     return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
  1603. }
  1604. END_OF_FUNC
  1605.  
  1606.  
  1607. 'script_name' => <<'END_OF_FUNC',
  1608. sub script_name {
  1609.     return $ENV{'SCRIPT_NAME'} if $ENV{'SCRIPT_NAME'};
  1610.     return "/$0" unless $0=~/^\//;
  1611.     return $0;
  1612. }
  1613. END_OF_FUNC
  1614.  
  1615.  
  1616. 'referer' => <<'END_OF_FUNC',
  1617. sub referer {
  1618.     my($self) = self_or_CGI(@_);
  1619.     return $self->http('referer');
  1620. }
  1621. END_OF_FUNC
  1622.  
  1623.  
  1624. 'server_name' => <<'END_OF_FUNC',
  1625. sub server_name {
  1626.     return $ENV{'SERVER_NAME'} || 'localhost';
  1627. }
  1628. END_OF_FUNC
  1629.  
  1630. 'server_software' => <<'END_OF_FUNC',
  1631. sub server_software {
  1632.     return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
  1633. }
  1634. END_OF_FUNC
  1635.  
  1636. 'server_port' => <<'END_OF_FUNC',
  1637. sub server_port {
  1638.     return $ENV{'SERVER_PORT'} || 80; # for debugging
  1639. }
  1640. END_OF_FUNC
  1641.  
  1642. 'server_protocol' => <<'END_OF_FUNC',
  1643. sub server_protocol {
  1644.     return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
  1645. }
  1646. END_OF_FUNC
  1647.  
  1648. 'http' => <<'END_OF_FUNC',
  1649. sub http {
  1650.     my ($self,$parameter) = self_or_CGI(@_);
  1651.     return $ENV{$parameter} if $parameter=~/^HTTP/;
  1652.     return $ENV{"HTTP_\U$parameter\E"} if $parameter;
  1653.     my(@p);
  1654.     foreach (keys %ENV) {
  1655.     push(@p,$_) if /^HTTP/;
  1656.     }
  1657.     return @p;
  1658. }
  1659. END_OF_FUNC
  1660.  
  1661. 'https' => <<'END_OF_FUNC',
  1662. sub https {
  1663.     local($^W)=0;
  1664.     my ($self,$parameter) = self_or_CGI(@_);
  1665.     return $ENV{HTTPS} unless $parameter;
  1666.     return $ENV{$parameter} if $parameter=~/^HTTPS/;
  1667.     return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
  1668.     my(@p);
  1669.     foreach (keys %ENV) {
  1670.     push(@p,$_) if /^HTTPS/;
  1671.     }
  1672.     return @p;
  1673. }
  1674. END_OF_FUNC
  1675.  
  1676. 'protocol' => <<'END_OF_FUNC',
  1677. sub protocol {
  1678.     local($^W)=0;
  1679.     my $self = shift;
  1680.     return 'https' if $self->https() eq 'ON'; 
  1681.     return 'https' if $self->server_port == 443;
  1682.     my $prot = $self->server_protocol;
  1683.     my($protocol,$version) = split('/',$prot);
  1684.     return "\L$protocol\E";
  1685. }
  1686. END_OF_FUNC
  1687.  
  1688. 'remote_ident' => <<'END_OF_FUNC',
  1689. sub remote_ident {
  1690.     return $ENV{'REMOTE_IDENT'};
  1691. }
  1692. END_OF_FUNC
  1693.  
  1694.  
  1695. 'auth_type' => <<'END_OF_FUNC',
  1696. sub auth_type {
  1697.     return $ENV{'AUTH_TYPE'};
  1698. }
  1699. END_OF_FUNC
  1700.  
  1701.  
  1702. 'remote_user' => <<'END_OF_FUNC',
  1703. sub remote_user {
  1704.     return $ENV{'REMOTE_USER'};
  1705. }
  1706. END_OF_FUNC
  1707.  
  1708.  
  1709. 'user_name' => <<'END_OF_FUNC',
  1710. sub user_name {
  1711.     my ($self) = self_or_CGI(@_);
  1712.     return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
  1713. }
  1714. END_OF_FUNC
  1715.  
  1716. 'nph' => <<'END_OF_FUNC',
  1717. sub nph {
  1718.     my ($self,$param) = self_or_CGI(@_);
  1719.     $CGI::NPH = $param if defined($param);
  1720.     return $CGI::NPH;
  1721. }
  1722. END_OF_FUNC
  1723.  
  1724. 'private_tempfiles' => <<'END_OF_FUNC',
  1725. sub private_tempfiles {
  1726.     my ($self,$param) = self_or_CGI(@_);
  1727.     $CGI::$PRIVATE_TEMPFILES = $param if defined($param);
  1728.     return $CGI::PRIVATE_TEMPFILES;
  1729. }
  1730. END_OF_FUNC
  1731.  
  1732. 'previous_or_default' => <<'END_OF_FUNC',
  1733. sub previous_or_default {
  1734.     my($self,$name,$defaults,$override) = @_;
  1735.     my(%selected);
  1736.  
  1737.     if (!$override && ($self->{'.fieldnames'}->{$name} || 
  1738.                defined($self->param($name)) ) ) {
  1739.     grep($selected{$_}++,$self->param($name));
  1740.     } elsif (defined($defaults) && ref($defaults) && 
  1741.          (ref($defaults) eq 'ARRAY')) {
  1742.     grep($selected{$_}++,@{$defaults});
  1743.     } else {
  1744.     $selected{$defaults}++ if defined($defaults);
  1745.     }
  1746.  
  1747.     return %selected;
  1748. }
  1749. END_OF_FUNC
  1750.  
  1751. 'register_parameter' => <<'END_OF_FUNC',
  1752. sub register_parameter {
  1753.     my($self,$param) = @_;
  1754.     $self->{'.parametersToAdd'}->{$param}++;
  1755. }
  1756. END_OF_FUNC
  1757.  
  1758. 'get_fields' => <<'END_OF_FUNC',
  1759. sub get_fields {
  1760.     my($self) = @_;
  1761.     return $self->hidden('-name'=>'.cgifields',
  1762.              '-values'=>[keys %{$self->{'.parametersToAdd'}}],
  1763.              '-override'=>1);
  1764. }
  1765. END_OF_FUNC
  1766.  
  1767. 'read_from_cmdline' => <<'END_OF_FUNC',
  1768. sub read_from_cmdline {
  1769.     require "shellwords.pl";
  1770.     my($input,@words);
  1771.     my($query_string);
  1772.     if (@ARGV) {
  1773.     $input = join(" ",@ARGV);
  1774.     } else {
  1775.     print STDERR "(offline mode: enter name=value pairs on standard input)\n";
  1776.     chomp(@lines = <>); # remove newlines
  1777.     $input = join(" ",@lines);
  1778.     }
  1779.  
  1780.     $input=~s/\\=/%3D/g;
  1781.     $input=~s/\\&/%26/g;
  1782.     
  1783.     @words = &shellwords($input);
  1784.     if ("@words"=~/=/) {
  1785.     $query_string = join('&',@words);
  1786.     } else {
  1787.     $query_string = join('+',@words);
  1788.     }
  1789.     return $query_string;
  1790. }
  1791. END_OF_FUNC
  1792.  
  1793. 'read_multipart' => <<'END_OF_FUNC',
  1794. sub read_multipart {
  1795.     my($self,$boundary,$length) = @_;
  1796.     my($buffer) = $self->new_MultipartBuffer($boundary,$length);
  1797.     return unless $buffer;
  1798.     my(%header,$body);
  1799.     while (!$buffer->eof) {
  1800.     %header = $buffer->readHeader;
  1801.     die "Malformed multipart POST\n" unless %header;
  1802.  
  1803.     my($key) = $header{'Content-disposition'} ? 'Content-disposition' : 'Content-Disposition';
  1804.     my($param)= $header{$key}=~/ name="([^\"]*)"/;
  1805.  
  1806.     my($filename) = $header{$key}=~/ filename="(.*)"$/;
  1807.  
  1808.     $self->add_parameter($param);
  1809.  
  1810.     unless ($filename) {
  1811.         my($value) = $buffer->readBody;
  1812.         push(@{$self->{$param}},$value);
  1813.         next;
  1814.     }
  1815.  
  1816.     my($tmpfile) = new TempFile;
  1817.     my $tmp = $tmpfile->as_string;
  1818.     
  1819.     my($filehandle);
  1820.     if ($filename=~/^[a-zA-Z_]/) {
  1821.         my($frame,$cp)=(1);
  1822.         do { $cp = caller($frame++); } until !eval("'$cp'->isaCGI()");
  1823.         $filehandle = "$cp\:\:$filename";
  1824.     } else {
  1825.         $filehandle = "\:\:$filename";
  1826.     }
  1827.  
  1828.  
  1829.     unless (defined(&O_RDWR)) {
  1830.         require Fcntl;
  1831.         import Fcntl qw/O_RDWR O_CREAT O_EXCL/;
  1832.     }
  1833.     sysopen($filehandle,$tmp,&O_RDWR|&O_CREAT|&O_EXCL) || die "CGI open of $tmp: $!\n";
  1834.     unlink($tmp) if $PRIVATE_TEMPFILES;
  1835.  
  1836.     $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
  1837.     chmod 0600,$tmp;    # only the owner can tamper with it
  1838.     my $data;
  1839.     while (defined($data = $buffer->read)) {
  1840.         print $filehandle $data;
  1841.     }
  1842.  
  1843.     seek($filehandle,0,0); #rewind file
  1844.     push(@{$self->{$param}},$filename);
  1845.  
  1846.     $self->{'.tmpfiles'}->{$filename}= {
  1847.         name=>($PRIVATE_TEMPFILES ? '' : $tmpfile),
  1848.         info=>{%header}
  1849.     }
  1850.     }
  1851. }
  1852. END_OF_FUNC
  1853.  
  1854. 'tmpFileName' => <<'END_OF_FUNC',
  1855. sub tmpFileName {
  1856.     my($self,$filename) = self_or_default(@_);
  1857.     return $self->{'.tmpfiles'}->{$filename}->{name} ?
  1858.     $self->{'.tmpfiles'}->{$filename}->{name}->as_string
  1859.         : '';
  1860. }
  1861. END_OF_FUNC
  1862.  
  1863. 'uploadInfo' => <<'END_OF_FUNC'
  1864. sub uploadInfo {
  1865.     my($self,$filename) = self_or_default(@_);
  1866.     return $self->{'.tmpfiles'}->{$filename}->{info};
  1867. }
  1868. END_OF_FUNC
  1869.  
  1870. );
  1871. END_OF_AUTOLOAD
  1872. ;
  1873.  
  1874. package MultipartBuffer;
  1875.  
  1876. $FILLUNIT = 1024 * 5;
  1877. $TIMEOUT = 10*60;       # 10 minute timeout
  1878. $SPIN_LOOP_MAX = 1000;  # bug fix for some Netscape servers
  1879. $CRLF=$CGI::CRLF;
  1880.  
  1881. *MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
  1882.  
  1883. $AUTOLOADED_ROUTINES = '';      # prevent -w error
  1884. $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
  1885. %SUBS =  (
  1886.  
  1887. 'new' => <<'END_OF_FUNC',
  1888. sub new {
  1889.     my($package,$interface,$boundary,$length,$filehandle) = @_;
  1890.     my $IN;
  1891.     if ($filehandle) {
  1892.     my($package) = caller;
  1893.     $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; 
  1894.     }
  1895.     $IN = "main::STDIN" unless $IN;
  1896.  
  1897.     $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
  1898.     
  1899.  
  1900.     if ($boundary) {
  1901.  
  1902.     $boundary = "--$boundary";
  1903.     my($null) = '';
  1904.     $length -= $interface->read_from_client($IN,\$null,length($boundary)+2,0);
  1905.     } else { # otherwise we find it ourselves
  1906.     my($old);
  1907.     ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
  1908.     $boundary = <$IN>;      # BUG: This won't work correctly under mod_perl
  1909.     $length -= length($boundary);
  1910.     chomp($boundary);               # remove the CRLF
  1911.     $/ = $old;                      # restore old line separator
  1912.     }
  1913.  
  1914.     my $self = {LENGTH=>$length,
  1915.         BOUNDARY=>$boundary,
  1916.         IN=>$IN,
  1917.         INTERFACE=>$interface,
  1918.         BUFFER=>'',
  1919.         };
  1920.  
  1921.     $FILLUNIT = length($boundary)
  1922.     if length($boundary) > $FILLUNIT;
  1923.  
  1924.     return bless $self,ref $package || $package;
  1925. }
  1926. END_OF_FUNC
  1927.  
  1928. 'readHeader' => <<'END_OF_FUNC',
  1929. sub readHeader {
  1930.     my($self) = @_;
  1931.     my($end);
  1932.     my($ok) = 0;
  1933.     my($bad) = 0;
  1934.     do {
  1935.     $self->fillBuffer($FILLUNIT);
  1936.     $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
  1937.     $ok++ if $self->{BUFFER} eq '';
  1938.     $bad++ if !$ok && $self->{LENGTH} <= 0;
  1939.     $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; 
  1940.     } until $ok || $bad;
  1941.     return () if $bad;
  1942.  
  1943.     my($header) = substr($self->{BUFFER},0,$end+2);
  1944.     substr($self->{BUFFER},0,$end+4) = '';
  1945.     my %return;
  1946.     while ($header=~/^([\w-]+): (.*)$CRLF/mog) {
  1947.     $return{$1}=$2;
  1948.     }
  1949.     return %return;
  1950. }
  1951. END_OF_FUNC
  1952.  
  1953. 'readBody' => <<'END_OF_FUNC',
  1954. sub readBody {
  1955.     my($self) = @_;
  1956.     my($data);
  1957.     my($returnval)='';
  1958.     while (defined($data = $self->read)) {
  1959.     $returnval .= $data;
  1960.     }
  1961.     return $returnval;
  1962. }
  1963. END_OF_FUNC
  1964.  
  1965. 'read' => <<'END_OF_FUNC',
  1966. sub read {
  1967.     my($self,$bytes) = @_;
  1968.  
  1969.     $bytes = $bytes || $FILLUNIT;       
  1970.  
  1971.     $self->fillBuffer($bytes);
  1972.  
  1973.     my $start = index($self->{BUFFER},$self->{BOUNDARY});
  1974.     die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
  1975.  
  1976.     if ($start == 0) {
  1977.  
  1978.     if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
  1979.         $self->{BUFFER}='';
  1980.         $self->{LENGTH}=0;
  1981.         return undef;
  1982.     }
  1983.  
  1984.     substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
  1985.     return undef;
  1986.     }
  1987.  
  1988.     my $bytesToReturn;    
  1989.     if ($start > 0) {           # read up to the boundary
  1990.     $bytesToReturn = $start > $bytes ? $bytes : $start;
  1991.     } else {    # read the requested number of bytes
  1992.     $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
  1993.     }
  1994.  
  1995.     my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
  1996.     substr($self->{BUFFER},0,$bytesToReturn)='';
  1997.     
  1998.     return ($start > 0) ? substr($returnval,0,-2) : $returnval;
  1999. }
  2000. END_OF_FUNC
  2001.  
  2002.  
  2003. 'fillBuffer' => <<'END_OF_FUNC',
  2004. sub fillBuffer {
  2005.     my($self,$bytes) = @_;
  2006.     return unless $self->{LENGTH};
  2007.  
  2008.     my($boundaryLength) = length($self->{BOUNDARY});
  2009.     my($bufferLength) = length($self->{BUFFER});
  2010.     my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
  2011.     $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
  2012.  
  2013.     my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN},
  2014.                              \$self->{BUFFER},
  2015.                              $bytesToRead,
  2016.                              $bufferLength);
  2017.  
  2018.     if ($bytesRead == 0) {
  2019.     die  "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
  2020.         if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
  2021.     } else {
  2022.     $self->{ZERO_LOOP_COUNTER}=0;
  2023.     }
  2024.  
  2025.     $self->{LENGTH} -= $bytesRead;
  2026. }
  2027. END_OF_FUNC
  2028.  
  2029.  
  2030. 'eof' => <<'END_OF_FUNC'
  2031. sub eof {
  2032.     my($self) = @_;
  2033.     return 1 if (length($self->{BUFFER}) == 0)
  2034.          && ($self->{LENGTH} <= 0);
  2035.     undef;
  2036. }
  2037. END_OF_FUNC
  2038.  
  2039. );
  2040. END_OF_AUTOLOAD
  2041.  
  2042. package TempFile;
  2043.  
  2044. $SL = $CGI::SL;
  2045. unless ($TMPDIRECTORY) {
  2046.     @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp","${SL}tmp","${SL}temp","${SL}Temporary Items");
  2047.     foreach (@TEMP) {
  2048.     do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
  2049.     }
  2050. }
  2051.  
  2052. $TMPDIRECTORY  = "." unless $TMPDIRECTORY;
  2053. $SEQUENCE="CGItemp${$}0000";
  2054.  
  2055. *TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
  2056.  
  2057. $AUTOLOADED_ROUTINES = '';      # prevent -w error
  2058. $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
  2059. %SUBS = (
  2060.  
  2061. 'new' => <<'END_OF_FUNC',
  2062. sub new {
  2063.     my($package) = @_;
  2064.     $SEQUENCE++;
  2065.     my $directory = "${TMPDIRECTORY}${SL}${SEQUENCE}";
  2066.     return bless \$directory;
  2067. }
  2068. END_OF_FUNC
  2069.  
  2070. 'DESTROY' => <<'END_OF_FUNC',
  2071. sub DESTROY {
  2072.     my($self) = @_;
  2073.     unlink $$self;              # get rid of the file
  2074. }
  2075. END_OF_FUNC
  2076.  
  2077. 'as_string' => <<'END_OF_FUNC'
  2078. sub as_string {
  2079.     my($self) = @_;
  2080.     return $$self;
  2081. }
  2082. END_OF_FUNC
  2083.  
  2084. );
  2085. END_OF_AUTOLOAD
  2086.  
  2087. package CGI;
  2088.  
  2089. if ($^W) {
  2090.     $CGI::CGI = '';
  2091.     $CGI::CGI=<<EOF;
  2092.     $CGI::VERSION;
  2093.     $MultipartBuffer::SPIN_LOOP_MAX;
  2094.     $MultipartBuffer::CRLF;
  2095.     $MultipartBuffer::TIMEOUT;
  2096.     $MultipartBuffer::FILLUNIT;
  2097.     $TempFile::SEQUENCE;
  2098. EOF
  2099.     ;
  2100. }
  2101.  
  2102. $revision;
  2103.  
  2104. __END__
  2105.  
  2106. =head1 NAME
  2107.  
  2108. CGI - Simple Common Gateway Interface Class
  2109.  
  2110. =head1 SYNOPSIS
  2111.  
  2112.   use CGI;
  2113.  
  2114. =head1 ABSTRACT
  2115.  
  2116. This perl library uses perl5 objects to make it easy to create
  2117. Web fill-out forms and parse their contents.  This package
  2118. defines CGI objects, entities that contain the values of the
  2119. current query string and other state variables.
  2120. Using a CGI object's methods, you can examine keywords and parameters
  2121. passed to your script, and create forms whose initial values
  2122. are taken from the current query (thereby preserving state
  2123. information).
  2124.  
  2125. The current version of CGI.pm is available at
  2126.  
  2127.   http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
  2128.   ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
  2129.  
  2130. =head1 INSTALLATION
  2131.  
  2132. CGI is a part of the base Perl installation.  However, you may need
  2133. to install a newer version someday.  Therefore:
  2134.  
  2135. To install this package, just change to the directory in which this
  2136. file is found and type the following:
  2137.  
  2138.     perl Makefile.PL
  2139.     make
  2140.     make install
  2141.  
  2142. This will copy CGI.pm to your perl library directory for use by all
  2143. perl scripts.  You probably must be root to do this.   Now you can
  2144. load the CGI routines in your Perl scripts with the line:
  2145.  
  2146.     use CGI;
  2147.  
  2148. If you don't have sufficient privileges to install CGI.pm in the Perl
  2149. library directory, you can put CGI.pm into some convenient spot, such
  2150. as your home directory, or in cgi-bin itself and prefix all Perl
  2151. scripts that call it with something along the lines of the following
  2152. preamble:
  2153.  
  2154.     use lib '/home/davis/lib';
  2155.     use CGI;
  2156.  
  2157. If you are using a version of perl earlier than 5.002 (such as NT perl), use
  2158. this instead:
  2159.  
  2160.     BEGIN {
  2161.         unshift(@INC,'/home/davis/lib');
  2162.     }
  2163.     use CGI;
  2164.  
  2165. The CGI distribution also comes with a cute module called L<CGI::Carp>.
  2166. It redefines the die(), warn(), confess() and croak() error routines
  2167. so that they write nicely formatted error messages into the server's
  2168. error log (or to the output stream of your choice).  This avoids long
  2169. hours of groping through the error and access logs, trying to figure
  2170. out which CGI script is generating  error messages.  If you choose,
  2171. you can even have fatal error messages echoed to the browser to avoid
  2172. the annoying and uninformative "Server Error" message.
  2173.  
  2174. =head1 DESCRIPTION
  2175.  
  2176. =head2 CREATING A NEW QUERY OBJECT:
  2177.  
  2178.      $query = new CGI;
  2179.  
  2180. This will parse the input (from both POST and GET methods) and store
  2181. it into a perl5 object called $query.  
  2182.  
  2183. =head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
  2184.  
  2185.      $query = new CGI(INPUTFILE);
  2186.  
  2187. If you provide a file handle to the new() method, it
  2188. will read parameters from the file (or STDIN, or whatever).  The
  2189. file can be in any of the forms describing below under debugging
  2190. (i.e. a series of newline delimited TAG=VALUE pairs will work).
  2191. Conveniently, this type of file is created by the save() method
  2192. (see below).  Multiple records can be saved and restored.
  2193.  
  2194. Perl purists will be pleased to know that this syntax accepts
  2195. references to file handles, or even references to filehandle globs,
  2196. which is the "official" way to pass a filehandle:
  2197.  
  2198.     $query = new CGI(\*STDIN);
  2199.  
  2200. You can also initialize the query object from an associative array
  2201. reference:
  2202.  
  2203.     $query = new CGI( {'dinosaur'=>'barney',
  2204.                'song'=>'I love you',
  2205.                'friends'=>[qw/Jessica George Nancy/]}
  2206.             );
  2207.  
  2208. or from a properly formatted, URL-escaped query string:
  2209.  
  2210.     $query = new CGI('dinosaur=barney&color=purple');
  2211.  
  2212. To create an empty query, initialize it from an empty string or hash:
  2213.  
  2214.     $empty_query = new CGI("");
  2215.          -or-
  2216.     $empty_query = new CGI({});
  2217.  
  2218. =head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
  2219.  
  2220.      @keywords = $query->keywords
  2221.  
  2222. If the script was invoked as the result of an <ISINDEX> search, the
  2223. parsed keywords can be obtained as an array using the keywords() method.
  2224.  
  2225. =head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
  2226.  
  2227.      @names = $query->param
  2228.  
  2229. If the script was invoked with a parameter list
  2230. (e.g. "name1=value1&name2=value2&name3=value3"), the param()
  2231. method will return the parameter names as a list.  If the
  2232. script was invoked as an <ISINDEX> script, there will be a
  2233. single parameter named 'keywords'.
  2234.  
  2235. NOTE: As of version 1.5, the array of parameter names returned will
  2236. be in the same order as they were submitted by the browser.
  2237. Usually this order is the same as the order in which the 
  2238. parameters are defined in the form (however, this isn't part
  2239. of the spec, and so isn't guaranteed).
  2240.  
  2241. =head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
  2242.  
  2243.     @values = $query->param('foo');
  2244.  
  2245.           -or-
  2246.  
  2247.     $value = $query->param('foo');
  2248.  
  2249. Pass the param() method a single argument to fetch the value of the
  2250. named parameter. If the parameter is multivalued (e.g. from multiple
  2251. selections in a scrolling list), you can ask to receive an array.  Otherwise
  2252. the method will return a single value.
  2253.  
  2254. =head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
  2255.  
  2256.     $query->param('foo','an','array','of','values');
  2257.  
  2258. This sets the value for the named parameter 'foo' to an array of
  2259. values.  This is one way to change the value of a field AFTER
  2260. the script has been invoked once before.  (Another way is with
  2261. the -override parameter accepted by all methods that generate
  2262. form elements.)
  2263.  
  2264. param() also recognizes a named parameter style of calling described
  2265. in more detail later:
  2266.  
  2267.     $query->param(-name=>'foo',-values=>['an','array','of','values']);
  2268.  
  2269.                   -or-
  2270.  
  2271.     $query->param(-name=>'foo',-value=>'the value');
  2272.  
  2273. =head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
  2274.  
  2275.    $query->append(-name=>;'foo',-values=>['yet','more','values']);
  2276.  
  2277. This adds a value or list of values to the named parameter.  The
  2278. values are appended to the end of the parameter if it already exists.
  2279. Otherwise the parameter is created.  Note that this method only
  2280. recognizes the named argument calling syntax.
  2281.  
  2282. =head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
  2283.  
  2284.    $query->import_names('R');
  2285.  
  2286. This creates a series of variables in the 'R' namespace.  For example,
  2287. $R::foo, @R:foo.  For keyword lists, a variable @R::keywords will appear.
  2288. If no namespace is given, this method will assume 'Q'.
  2289. WARNING:  don't import anything into 'main'; this is a major security
  2290. risk!!!!
  2291.  
  2292. In older versions, this method was called B<import()>.  As of version 2.20, 
  2293. this name has been removed completely to avoid conflict with the built-in
  2294. Perl module B<import> operator.
  2295.  
  2296. =head2 DELETING A PARAMETER COMPLETELY:
  2297.  
  2298.     $query->delete('foo');
  2299.  
  2300. This completely clears a parameter.  It sometimes useful for
  2301. resetting parameters that you don't want passed down between
  2302. script invocations.
  2303.  
  2304. =head2 DELETING ALL PARAMETERS:
  2305.  
  2306. $query->delete_all();
  2307.  
  2308. This clears the CGI object completely.  It might be useful to ensure
  2309. that all the defaults are taken when you create a fill-out form.
  2310.  
  2311. =head2 SAVING THE STATE OF THE FORM TO A FILE:
  2312.  
  2313.     $query->save(FILEHANDLE)
  2314.  
  2315. This will write the current state of the form to the provided
  2316. filehandle.  You can read it back in by providing a filehandle
  2317. to the new() method.  Note that the filehandle can be a file, a pipe,
  2318. or whatever!
  2319.  
  2320. The format of the saved file is:
  2321.  
  2322.     NAME1=VALUE1
  2323.     NAME1=VALUE1'
  2324.     NAME2=VALUE2
  2325.     NAME3=VALUE3
  2326.     =
  2327.  
  2328. Both name and value are URL escaped.  Multi-valued CGI parameters are
  2329. represented as repeated names.  A session record is delimited by a
  2330. single = symbol.  You can write out multiple records and read them
  2331. back in with several calls to B<new>.  You can do this across several
  2332. sessions by opening the file in append mode, allowing you to create
  2333. primitive guest books, or to keep a history of users' queries.  Here's
  2334. a short example of creating multiple session records:
  2335.  
  2336.    use CGI;
  2337.  
  2338.    open (OUT,">>test.out") || die;
  2339.    $records = 5;
  2340.    foreach (0..$records) {
  2341.        my $q = new CGI;
  2342.        $q->param(-name=>'counter',-value=>$_);
  2343.        $q->save(OUT);
  2344.    }
  2345.    close OUT;
  2346.  
  2347.    open (IN,"test.out") || die;
  2348.    while (!eof(IN)) {
  2349.        my $q = new CGI(IN);
  2350.        print $q->param('counter'),"\n";
  2351.    }
  2352.  
  2353. The file format used for save/restore is identical to that used by the
  2354. Whitehead Genome Center's data exchange format "Boulderio", and can be
  2355. manipulated and even databased using Boulderio utilities.  See
  2356.     
  2357.   http://www.genome.wi.mit.edu/genome_software/other/boulder.html
  2358.  
  2359. for further details.
  2360.  
  2361. =head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
  2362.  
  2363.     $myself = $query->self_url;
  2364.     print "<A HREF=$myself>I'm talking to myself.</A>";
  2365.  
  2366. self_url() will return a URL, that, when selected, will reinvoke
  2367. this script with all its state information intact.  This is most
  2368. useful when you want to jump around within the document using
  2369. internal anchors but you don't want to disrupt the current contents
  2370. of the form(s).  Something like this will do the trick.
  2371.  
  2372.      $myself = $query->self_url;
  2373.      print "<A HREF=$myself#table1>See table 1</A>";
  2374.      print "<A HREF=$myself#table2>See table 2</A>";
  2375.      print "<A HREF=$myself#yourself>See for yourself</A>";
  2376.  
  2377. If you don't want to get the whole query string, call
  2378. the method url() to return just the URL for the script:
  2379.  
  2380.     $myself = $query->url;
  2381.     print "<A HREF=$myself>No query string in this baby!</A>\n";
  2382.  
  2383. You can also retrieve the unprocessed query string with query_string():
  2384.  
  2385.     $the_string = $query->query_string;
  2386.  
  2387. =head2 COMPATIBILITY WITH CGI-LIB.PL
  2388.  
  2389. To make it easier to port existing programs that use cgi-lib.pl
  2390. the compatibility routine "ReadParse" is provided.  Porting is
  2391. simple:
  2392.  
  2393. OLD VERSION
  2394.     require "cgi-lib.pl";
  2395.     &ReadParse;
  2396.     print "The value of the antique is $in{antique}.\n";
  2397.  
  2398. NEW VERSION
  2399.     use CGI;
  2400.     CGI::ReadParse
  2401.     print "The value of the antique is $in{antique}.\n";
  2402.  
  2403. CGI.pm's ReadParse() routine creates a tied variable named %in,
  2404. which can be accessed to obtain the query variables.  Like
  2405. ReadParse, you can also provide your own variable.  Infrequently
  2406. used features of ReadParse, such as the creation of @in and $in 
  2407. variables, are not supported.
  2408.  
  2409. Once you use ReadParse, you can retrieve the query object itself
  2410. this way:
  2411.  
  2412.     $q = $in{CGI};
  2413.     print $q->textfield(-name=>'wow',
  2414.             -value=>'does this really work?');
  2415.  
  2416. This allows you to start using the more interesting features
  2417. of CGI.pm without rewriting your old scripts from scratch.
  2418.  
  2419. =head2 CALLING CGI FUNCTIONS THAT TAKE MULTIPLE ARGUMENTS
  2420.  
  2421. In versions of CGI.pm prior to 2.0, it could get difficult to remember
  2422. the proper order of arguments in CGI function calls that accepted five
  2423. or six different arguments.  As of 2.0, there's a better way to pass
  2424. arguments to the various CGI functions.  In this style, you pass a
  2425. series of name=>argument pairs, like this:
  2426.  
  2427.    $field = $query->radio_group(-name=>'OS',
  2428.                 -values=>[Unix,Windows,Macintosh],
  2429.                 -default=>'Unix');
  2430.  
  2431. The advantages of this style are that you don't have to remember the
  2432. exact order of the arguments, and if you leave out a parameter, in
  2433. most cases it will default to some reasonable value.  If you provide
  2434. a parameter that the method doesn't recognize, it will usually do
  2435. something useful with it, such as incorporating it into the HTML form
  2436. tag.  For example if Netscape decides next week to add a new
  2437. JUSTIFICATION parameter to the text field tags, you can start using
  2438. the feature without waiting for a new version of CGI.pm:
  2439.  
  2440.    $field = $query->textfield(-name=>'State',
  2441.                   -default=>'gaseous',
  2442.                   -justification=>'RIGHT');
  2443.  
  2444. This will result in an HTML tag that looks like this:
  2445.  
  2446.     <INPUT TYPE="textfield" NAME="State" VALUE="gaseous"
  2447.            JUSTIFICATION="RIGHT">
  2448.  
  2449. Parameter names are case insensitive: you can use -name, or -Name or
  2450. -NAME.  You don't have to use the hyphen if you don't want to.  After
  2451. creating a CGI object, call the B<use_named_parameters()> method with
  2452. a nonzero value.  This will tell CGI.pm that you intend to use named
  2453. parameters exclusively:
  2454.  
  2455.    $query = new CGI;
  2456.    $query->use_named_parameters(1);
  2457.    $field = $query->radio_group('name'=>'OS',
  2458.                 'values'=>['Unix','Windows','Macintosh'],
  2459.                 'default'=>'Unix');
  2460.  
  2461. Actually, CGI.pm only looks for a hyphen in the first parameter.  So
  2462. you can leave it off subsequent parameters if you like.  Something to
  2463. be wary of is the potential that a string constant like "values" will
  2464. collide with a keyword (and in fact it does!) While Perl usually
  2465. figures out when you're referring to a function and when you're
  2466. referring to a string, you probably should put quotation marks around
  2467. all string constants just to play it safe.
  2468.  
  2469. =head2 CREATING THE HTTP HEADER:
  2470.  
  2471.     print $query->header;
  2472.  
  2473.          -or-
  2474.  
  2475.     print $query->header('image/gif');
  2476.  
  2477.          -or-
  2478.  
  2479.     print $query->header('text/html','204 No response');
  2480.  
  2481.          -or-
  2482.  
  2483.     print $query->header(-type=>'image/gif',
  2484.                  -nph=>1,
  2485.                  -status=>'402 Payment required',
  2486.                  -expires=>'+3d',
  2487.                  -cookie=>$cookie,
  2488.                  -Cost=>'$2.00');
  2489.  
  2490. header() returns the Content-type: header.  You can provide your own
  2491. MIME type if you choose, otherwise it defaults to text/html.  An
  2492. optional second parameter specifies the status code and a human-readable
  2493. message.  For example, you can specify 204, "No response" to create a
  2494. script that tells the browser to do nothing at all.  If you want to
  2495. add additional fields to the header, just tack them on to the end:
  2496.  
  2497.     print $query->header('text/html','200 OK','Content-Length: 3002');
  2498.  
  2499. The last example shows the named argument style for passing arguments
  2500. to the CGI methods using named parameters.  Recognized parameters are
  2501. B<-type>, B<-status>, B<-expires>, and B<-cookie>.  Any other 
  2502. parameters will be stripped of their initial hyphens and turned into
  2503. header fields, allowing you to specify any HTTP header you desire.
  2504.  
  2505. Most browsers will not cache the output from CGI scripts.  Every time
  2506. the browser reloads the page, the script is invoked anew.  You can
  2507. change this behavior with the B<-expires> parameter.  When you specify
  2508. an absolute or relative expiration interval with this parameter, some
  2509. browsers and proxy servers will cache the script's output until the
  2510. indicated expiration date.  The following forms are all valid for the
  2511. -expires field:
  2512.  
  2513.     +30s                              30 seconds from now
  2514.     +10m                              ten minutes from now
  2515.     +1h                               one hour from now
  2516.     -1d                               yesterday (i.e. "ASAP!")
  2517.     now                               immediately
  2518.     +3M                               in three months
  2519.     +10y                              in ten years time
  2520.     Thursday, 25-Apr-96 00:40:33 GMT  at the indicated time & date
  2521.  
  2522. (CGI::expires() is the static function call used internally that turns
  2523. relative time intervals into HTTP dates.  You can call it directly if
  2524. you wish.)
  2525.  
  2526. The B<-cookie> parameter generates a header that tells the browser to provide
  2527. a "magic cookie" during all subsequent transactions with your script.
  2528. Netscape cookies have a special format that includes interesting attributes
  2529. such as expiration time.  Use the cookie() method to create and retrieve
  2530. session cookies.
  2531.  
  2532. The B<-nph> parameter, if set to a true value, will issue the correct
  2533. headers to work with a NPH (no-parse-header) script.  This is important
  2534. to use with certain servers, such as Microsoft Internet Explorer, which
  2535. expect all their scripts to be NPH.
  2536.  
  2537. =head2 GENERATING A REDIRECTION INSTRUCTION
  2538.  
  2539.    print $query->redirect('http://somewhere.else/in/movie/land');
  2540.  
  2541. redirects the browser elsewhere.  If you use redirection like this,
  2542. you should B<not> print out a header as well.  As of version 2.0, we
  2543. produce both the unofficial Location: header and the official URI:
  2544. header.  This should satisfy most servers and browsers.
  2545.  
  2546. One hint I can offer is that relative links may not work correctly
  2547. when you generate a redirection to another document on your site.
  2548. This is due to a well-intentioned optimization that some servers use.
  2549. The solution to this is to use the full URL (including the http: part)
  2550. of the document you are redirecting to.
  2551.  
  2552. You can use named parameters:
  2553.  
  2554.     print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
  2555.                -nph=>1);
  2556.  
  2557. The B<-nph> parameter, if set to a true value, will issue the correct
  2558. headers to work with a NPH (no-parse-header) script.  This is important
  2559. to use with certain servers, such as Microsoft Internet Explorer, which
  2560. expect all their scripts to be NPH.
  2561.  
  2562.  
  2563. =head2 CREATING THE HTML HEADER:
  2564.  
  2565.    print $query->start_html(-title=>'Secrets of the Pyramids',
  2566.                 -author=>'fred@capricorn.org',
  2567.                 -base=>'true',
  2568.                 -target=>'_blank',
  2569.                 -meta=>{'keywords'=>'pharaoh secret mummy',
  2570.                     'copyright'=>'copyright 1996 King Tut'},
  2571.                 -style=>{'src'=>'/styles/style1.css'},
  2572.                 -BGCOLOR=>'blue');
  2573.  
  2574.    -or-
  2575.  
  2576.    print $query->start_html('Secrets of the Pyramids',
  2577.                 'fred@capricorn.org','true',
  2578.                 'BGCOLOR="blue"');
  2579.  
  2580. This will return a canned HTML header and the opening <BODY> tag.  
  2581. All parameters are optional.   In the named parameter form, recognized
  2582. parameters are -title, -author, -base, -xbase and -target (see below for the
  2583. explanation).  Any additional parameters you provide, such as the
  2584. Netscape unofficial BGCOLOR attribute, are added to the <BODY> tag.
  2585.  
  2586. The argument B<-xbase> allows you to provide an HREF for the <BASE> tag
  2587. different from the current location, as in
  2588.  
  2589.     -xbase=>"http://home.mcom.com/"
  2590.  
  2591. All relative links will be interpreted relative to this tag.
  2592.  
  2593. The argument B<-target> allows you to provide a default target frame
  2594. for all the links and fill-out forms on the page.  See the Netscape
  2595. documentation on frames for details of how to manipulate this.
  2596.  
  2597.     -target=>"answer_window"
  2598.  
  2599. All relative links will be interpreted relative to this tag.
  2600. You add arbitrary meta information to the header with the B<-meta>
  2601. argument.  This argument expects a reference to an associative array
  2602. containing name/value pairs of meta information.  These will be turned
  2603. into a series of header <META> tags that look something like this:
  2604.  
  2605.     <META NAME="keywords" CONTENT="pharaoh secret mummy">
  2606.     <META NAME="description" CONTENT="copyright 1996 King Tut">
  2607.  
  2608. There is no support for the HTTP-EQUIV type of <META> tag.  This is
  2609. because you can modify the HTTP header directly with the B<header()>
  2610. method.  For example, if you want to send the Refresh: header, do it
  2611. in the header() method:
  2612.  
  2613.     print $q->header(-Refresh=>'10; URL=http://www.capricorn.com');
  2614.  
  2615. The B<-style> tag is used to incorporate cascading stylesheets into
  2616. your code.  See the section on CASCADING STYLESHEETS for more information.
  2617.  
  2618. You can place other arbitrary HTML elements to the <HEAD> section with the
  2619. B<-head> tag.  For example, to place the rarely-used <LINK> element in the
  2620. head section, use this:
  2621.  
  2622.     print $q->header(-head=>link({-rel=>'next',
  2623.                   -href=>'http://www.capricorn.com/s2.html'}));
  2624.  
  2625. To incorporate multiple HTML elements into the <HEAD> section, just pass an
  2626. array reference:
  2627.  
  2628.     print $q->header(-head=>[ link({-rel=>'next',
  2629.                     -href=>'http://www.capricorn.com/s2.html'}),
  2630.                   link({-rel=>'previous',
  2631.                     -href=>'http://www.capricorn.com/s1.html'})
  2632.                  ]
  2633.              );
  2634.  
  2635.  
  2636. JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad> and B<-onUnload> parameters
  2637. are used to add Netscape JavaScript calls to your pages.  B<-script>
  2638. should point to a block of text containing JavaScript function
  2639. definitions.  This block will be placed within a <SCRIPT> block inside
  2640. the HTML (not HTTP) header.  The block is placed in the header in
  2641. order to give your page a fighting chance of having all its JavaScript
  2642. functions in place even if the user presses the stop button before the
  2643. page has loaded completely.  CGI.pm attempts to format the script in
  2644. such a way that JavaScript-naive browsers will not choke on the code:
  2645. unfortunately there are some browsers, such as Chimera for Unix, that
  2646. get confused by it nevertheless.
  2647.  
  2648. The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
  2649. code to execute when the page is respectively opened and closed by the
  2650. browser.  Usually these parameters are calls to functions defined in the
  2651. B<-script> field:
  2652.  
  2653.       $query = new CGI;
  2654.       print $query->header;
  2655.       $JSCRIPT=<<END;
  2656.       // Ask a silly question
  2657.       function riddle_me_this() {
  2658.      var r = prompt("What walks on four legs in the morning, " +
  2659.                "two legs in the afternoon, " +
  2660.                "and three legs in the evening?");
  2661.      response(r);
  2662.       }
  2663.       // Get a silly answer
  2664.       function response(answer) {
  2665.      if (answer == "man")
  2666.         alert("Right you are!");
  2667.      else
  2668.         alert("Wrong!  Guess again.");
  2669.       }
  2670.       END
  2671.       print $query->start_html(-title=>'The Riddle of the Sphinx',
  2672.                    -script=>$JSCRIPT);
  2673.  
  2674. Use the B<-noScript> parameter to pass some HTML text that will be displayed on 
  2675. browsers that do not have JavaScript (or browsers where JavaScript is turned
  2676. off).
  2677.  
  2678. Netscape 3.0 recognizes several attributes of the <SCRIPT> tag,
  2679. including LANGUAGE and SRC.  The latter is particularly interesting,
  2680. as it allows you to keep the JavaScript code in a file or CGI script
  2681. rather than cluttering up each page with the source.  To use these
  2682. attributes pass a HASH reference in the B<-script> parameter containing
  2683. one or more of -language, -src, or -code:
  2684.  
  2685.     print $q->start_html(-title=>'The Riddle of the Sphinx',
  2686.              -script=>{-language=>'JAVASCRIPT',
  2687.                                    -src=>'/javascript/sphinx.js'}
  2688.              );
  2689.  
  2690.     print $q->(-title=>'The Riddle of the Sphinx',
  2691.            -script=>{-language=>'PERLSCRIPT'},
  2692.              -code=>'print "hello world!\n;"'
  2693.            );
  2694.  
  2695.  
  2696. See
  2697.  
  2698.    http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
  2699.  
  2700. for more information about JavaScript.
  2701.  
  2702. The old-style positional parameters are as follows:
  2703.  
  2704. =over 4
  2705.  
  2706. =item B<Parameters:>
  2707.  
  2708. =item 1.
  2709.  
  2710. The title
  2711.  
  2712. =item 2.
  2713.  
  2714. The author's e-mail address (will create a <LINK REV="MADE"> tag if present
  2715.  
  2716. =item 3.
  2717.  
  2718. A 'true' flag if you want to include a <BASE> tag in the header.  This
  2719. helps resolve relative addresses to absolute ones when the document is moved, 
  2720. but makes the document hierarchy non-portable.  Use with care!
  2721.  
  2722. =item 4, 5, 6...
  2723.  
  2724. Any other parameters you want to include in the <BODY> tag.  This is a good
  2725. place to put Netscape extensions, such as colors and wallpaper patterns.
  2726.  
  2727. =back
  2728.  
  2729. =head2 ENDING THE HTML DOCUMENT:
  2730.  
  2731.     print $query->end_html
  2732.  
  2733. This ends an HTML document by printing the </BODY></HTML> tags.
  2734.  
  2735. =head1 CREATING FORMS
  2736.  
  2737. I<General note>  The various form-creating methods all return strings
  2738. to the caller, containing the tag or tags that will create the requested
  2739. form element.  You are responsible for actually printing out these strings.
  2740. It's set up this way so that you can place formatting tags
  2741. around the form elements.
  2742.  
  2743. I<Another note> The default values that you specify for the forms are only
  2744. used the B<first> time the script is invoked (when there is no query
  2745. string).  On subsequent invocations of the script (when there is a query
  2746. string), the former values are used even if they are blank.  
  2747.  
  2748. If you want to change the value of a field from its previous value, you have two
  2749. choices:
  2750.  
  2751. (1) call the param() method to set it.
  2752.  
  2753. (2) use the -override (alias -force) parameter (a new feature in version 2.15).
  2754. This forces the default value to be used, regardless of the previous value:
  2755.  
  2756.    print $query->textfield(-name=>'field_name',
  2757.                -default=>'starting value',
  2758.                -override=>1,
  2759.                -size=>50,
  2760.                -maxlength=>80);
  2761.  
  2762. I<Yet another note> By default, the text and labels of form elements are
  2763. escaped according to HTML rules.  This means that you can safely use
  2764. "<CLICK ME>" as the label for a button.  However, it also interferes with
  2765. your ability to incorporate special HTML character sequences, such as Á,
  2766. into your fields.  If you wish to turn off automatic escaping, call the
  2767. autoEscape() method with a false value immediately after creating the CGI object:
  2768.  
  2769.    $query = new CGI;
  2770.    $query->autoEscape(undef);
  2771.                  
  2772.  
  2773. =head2 CREATING AN ISINDEX TAG
  2774.  
  2775.    print $query->isindex(-action=>$action);
  2776.  
  2777.      -or-
  2778.  
  2779.    print $query->isindex($action);
  2780.  
  2781. Prints out an <ISINDEX> tag.  Not very exciting.  The parameter
  2782. -action specifies the URL of the script to process the query.  The
  2783. default is to process the query with the current script.
  2784.  
  2785. =head2 STARTING AND ENDING A FORM
  2786.  
  2787.     print $query->startform(-method=>$method,
  2788.                 -action=>$action,
  2789.                 -encoding=>$encoding);
  2790.       <... various form stuff ...>
  2791.     print $query->endform;
  2792.  
  2793.     -or-
  2794.  
  2795.     print $query->startform($method,$action,$encoding);
  2796.       <... various form stuff ...>
  2797.     print $query->endform;
  2798.  
  2799. startform() will return a <FORM> tag with the optional method,
  2800. action and form encoding that you specify.  The defaults are:
  2801.     
  2802.     method: POST
  2803.     action: this script
  2804.     encoding: application/x-www-form-urlencoded
  2805.  
  2806. endform() returns the closing </FORM> tag.  
  2807.  
  2808. Startform()'s encoding method tells the browser how to package the various
  2809. fields of the form before sending the form to the server.  Two
  2810. values are possible:
  2811.  
  2812. =over 4
  2813.  
  2814. =item B<application/x-www-form-urlencoded>
  2815.  
  2816. This is the older type of encoding used by all browsers prior to
  2817. Netscape 2.0.  It is compatible with many CGI scripts and is
  2818. suitable for short fields containing text data.  For your
  2819. convenience, CGI.pm stores the name of this encoding
  2820. type in B<$CGI::URL_ENCODED>.
  2821.  
  2822. =item B<multipart/form-data>
  2823.  
  2824. This is the newer type of encoding introduced by Netscape 2.0.
  2825. It is suitable for forms that contain very large fields or that
  2826. are intended for transferring binary data.  Most importantly,
  2827. it enables the "file upload" feature of Netscape 2.0 forms.  For
  2828. your convenience, CGI.pm stores the name of this encoding type
  2829. in B<$CGI::MULTIPART>
  2830.  
  2831. Forms that use this type of encoding are not easily interpreted
  2832. by CGI scripts unless they use CGI.pm or another library designed
  2833. to handle them.
  2834.  
  2835. =back
  2836.  
  2837. For compatibility, the startform() method uses the older form of
  2838. encoding by default.  If you want to use the newer form of encoding
  2839. by default, you can call B<start_multipart_form()> instead of
  2840. B<startform()>.
  2841.  
  2842. JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
  2843. for use with JavaScript.  The -name parameter gives the
  2844. form a name so that it can be identified and manipulated by
  2845. JavaScript functions.  -onSubmit should point to a JavaScript
  2846. function that will be executed just before the form is submitted to your
  2847. server.  You can use this opportunity to check the contents of the form 
  2848. for consistency and completeness.  If you find something wrong, you
  2849. can put up an alert box or maybe fix things up yourself.  You can 
  2850. abort the submission by returning false from this function.  
  2851.  
  2852. Usually the bulk of JavaScript functions are defined in a <SCRIPT>
  2853. block in the HTML header and -onSubmit points to one of these function
  2854. call.  See start_html() for details.
  2855.  
  2856. =head2 CREATING A TEXT FIELD
  2857.  
  2858.     print $query->textfield(-name=>'field_name',
  2859.                 -default=>'starting value',
  2860.                 -size=>50,
  2861.                 -maxlength=>80);
  2862.     -or-
  2863.  
  2864.     print $query->textfield('field_name','starting value',50,80);
  2865.  
  2866. textfield() will return a text input field.  
  2867.  
  2868. =over 4
  2869.  
  2870. =item B<Parameters>
  2871.  
  2872. =item 1.
  2873.  
  2874. The first parameter is the required name for the field (-name).  
  2875.  
  2876. =item 2.
  2877.  
  2878. The optional second parameter is the default starting value for the field
  2879. contents (-default).  
  2880.  
  2881. =item 3.
  2882.  
  2883. The optional third parameter is the size of the field in
  2884.       characters (-size).
  2885.  
  2886. =item 4.
  2887.  
  2888. The optional fourth parameter is the maximum number of characters the
  2889.       field will accept (-maxlength).
  2890.  
  2891. =back
  2892.  
  2893. As with all these methods, the field will be initialized with its 
  2894. previous contents from earlier invocations of the script.
  2895. When the form is processed, the value of the text field can be
  2896. retrieved with:
  2897.  
  2898.        $value = $query->param('foo');
  2899.  
  2900. If you want to reset it from its initial value after the script has been
  2901. called once, you can do so like this:
  2902.  
  2903.        $query->param('foo',"I'm taking over this value!");
  2904.  
  2905. NEW AS OF VERSION 2.15: If you don't want the field to take on its previous
  2906. value, you can force its current value by using the -override (alias -force)
  2907. parameter:
  2908.  
  2909.     print $query->textfield(-name=>'field_name',
  2910.                 -default=>'starting value',
  2911.                 -override=>1,
  2912.                 -size=>50,
  2913.                 -maxlength=>80);
  2914.  
  2915. JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>, B<-onBlur>
  2916. and B<-onSelect> parameters to register JavaScript event handlers.
  2917. The onChange handler will be called whenever the user changes the
  2918. contents of the text field.  You can do text validation if you like.
  2919. onFocus and onBlur are called respectively when the insertion point
  2920. moves into and out of the text field.  onSelect is called when the
  2921. user changes the portion of the text that is selected.
  2922.  
  2923. =head2 CREATING A BIG TEXT FIELD
  2924.  
  2925.    print $query->textarea(-name=>'foo',
  2926.               -default=>'starting value',
  2927.               -rows=>10,
  2928.               -columns=>50);
  2929.  
  2930.     -or
  2931.  
  2932.    print $query->textarea('foo','starting value',10,50);
  2933.  
  2934. textarea() is just like textfield, but it allows you to specify
  2935. rows and columns for a multiline text entry box.  You can provide
  2936. a starting value for the field, which can be long and contain
  2937. multiple lines.
  2938.  
  2939. JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
  2940. and B<-onSelect> parameters are recognized.  See textfield().
  2941.  
  2942. =head2 CREATING A PASSWORD FIELD
  2943.  
  2944.    print $query->password_field(-name=>'secret',
  2945.                 -value=>'starting value',
  2946.                 -size=>50,
  2947.                 -maxlength=>80);
  2948.     -or-
  2949.  
  2950.    print $query->password_field('secret','starting value',50,80);
  2951.  
  2952. password_field() is identical to textfield(), except that its contents 
  2953. will be starred out on the web page.
  2954.  
  2955. JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
  2956. and B<-onSelect> parameters are recognized.  See textfield().
  2957.  
  2958. =head2 CREATING A FILE UPLOAD FIELD
  2959.  
  2960.     print $query->filefield(-name=>'uploaded_file',
  2961.                 -default=>'starting value',
  2962.                 -size=>50,
  2963.                 -maxlength=>80);
  2964.     -or-
  2965.  
  2966.     print $query->filefield('uploaded_file','starting value',50,80);
  2967.  
  2968. filefield() will return a file upload field for Netscape 2.0 browsers.
  2969. In order to take full advantage of this I<you must use the new 
  2970. multipart encoding scheme> for the form.  You can do this either
  2971. by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>,
  2972. or by calling the new method B<start_multipart_form()> instead of
  2973. vanilla B<startform()>.
  2974.  
  2975. =over 4
  2976.  
  2977. =item B<Parameters>
  2978.  
  2979. =item 1.
  2980.  
  2981. The first parameter is the required name for the field (-name).  
  2982.  
  2983. =item 2.
  2984.  
  2985. The optional second parameter is the starting value for the field contents
  2986. to be used as the default file name (-default).
  2987.  
  2988. The beta2 version of Netscape 2.0 currently doesn't pay any attention
  2989. to this field, and so the starting value will always be blank.  Worse,
  2990. the field loses its "sticky" behavior and forgets its previous
  2991. contents.  The starting value field is called for in the HTML
  2992. specification, however, and possibly later versions of Netscape will
  2993. honor it.
  2994.  
  2995. =item 3.
  2996.  
  2997. The optional third parameter is the size of the field in
  2998. characters (-size).
  2999.  
  3000. =item 4.
  3001.  
  3002. The optional fourth parameter is the maximum number of characters the
  3003. field will accept (-maxlength).
  3004.  
  3005. =back
  3006.  
  3007. When the form is processed, you can retrieve the entered filename
  3008. by calling param().
  3009.  
  3010.        $filename = $query->param('uploaded_file');
  3011.  
  3012. In Netscape Gold, the filename that gets returned is the full local filename
  3013. on the B<remote user's> machine.  If the remote user is on a Unix
  3014. machine, the filename will follow Unix conventions:
  3015.  
  3016.     /path/to/the/file
  3017.  
  3018. On an MS-DOS/Windows and OS/2 machines, the filename will follow DOS conventions:
  3019.  
  3020.     C:\PATH\TO\THE\FILE.MSW
  3021.  
  3022. On a Macintosh machine, the filename will follow Mac conventions:
  3023.  
  3024.     HD 40:Desktop Folder:Sort Through:Reminders
  3025.  
  3026. The filename returned is also a file handle.  You can read the contents
  3027. of the file using standard Perl file reading calls:
  3028.  
  3029.     while (<$filename>) {
  3030.        print;
  3031.     }
  3032.  
  3033.     open (OUTFILE,">>/usr/local/web/users/feedback");
  3034.     while ($bytesread=read($filename,$buffer,1024)) {
  3035.        print OUTFILE $buffer;
  3036.     }
  3037.  
  3038. When a file is uploaded the browser usually sends along some
  3039. information along with it in the format of headers.  The information
  3040. usually includes the MIME content type.  Future browsers may send
  3041. other information as well (such as modification date and size). To
  3042. retrieve this information, call uploadInfo().  It returns a reference to
  3043. an associative array containing all the document headers.
  3044.  
  3045.        $filename = $query->param('uploaded_file');
  3046.        $type = $query->uploadInfo($filename)->{'Content-Type'};
  3047.        unless ($type eq 'text/html') {
  3048.       die "HTML FILES ONLY!";
  3049.        }
  3050.  
  3051. If you are using a machine that recognizes "text" and "binary" data
  3052. modes, be sure to understand when and how to use them (see the Camel book).  
  3053. Otherwise you may find that binary files are corrupted during file uploads.
  3054.  
  3055. JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
  3056. and B<-onSelect> parameters are recognized.  See textfield()
  3057. for details. 
  3058.  
  3059. =head2 CREATING A POPUP MENU
  3060.  
  3061.    print $query->popup_menu('menu_name',
  3062.                 ['eenie','meenie','minie'],
  3063.                 'meenie');
  3064.  
  3065.       -or-
  3066.  
  3067.    %labels = ('eenie'=>'your first choice',
  3068.           'meenie'=>'your second choice',
  3069.           'minie'=>'your third choice');
  3070.    print $query->popup_menu('menu_name',
  3071.                 ['eenie','meenie','minie'],
  3072.                 'meenie',\%labels);
  3073.  
  3074.     -or (named parameter style)-
  3075.  
  3076.    print $query->popup_menu(-name=>'menu_name',
  3077.                 -values=>['eenie','meenie','minie'],
  3078.                 -default=>'meenie',
  3079.                 -labels=>\%labels);
  3080.  
  3081. popup_menu() creates a menu.
  3082.  
  3083. =over 4
  3084.  
  3085. =item 1.
  3086.  
  3087. The required first argument is the menu's name (-name).
  3088.  
  3089. =item 2.
  3090.  
  3091. The required second argument (-values) is an array B<reference>
  3092. containing the list of menu items in the menu.  You can pass the
  3093. method an anonymous array, as shown in the example, or a reference to
  3094. a named array, such as "\@foo".
  3095.  
  3096. =item 3.
  3097.  
  3098. The optional third parameter (-default) is the name of the default
  3099. menu choice.  If not specified, the first item will be the default.
  3100. The values of the previous choice will be maintained across queries.
  3101.  
  3102. =item 4.
  3103.  
  3104. The optional fourth parameter (-labels) is provided for people who
  3105. want to use different values for the user-visible label inside the
  3106. popup menu nd the value returned to your script.  It's a pointer to an
  3107. associative array relating menu values to user-visible labels.  If you
  3108. leave this parameter blank, the menu values will be displayed by
  3109. default.  (You can also leave a label undefined if you want to).
  3110.  
  3111. =back
  3112.  
  3113. When the form is processed, the selected value of the popup menu can
  3114. be retrieved using:
  3115.  
  3116.       $popup_menu_value = $query->param('menu_name');
  3117.  
  3118. JAVASCRIPTING: popup_menu() recognizes the following event handlers:
  3119. B<-onChange>, B<-onFocus>, and B<-onBlur>.  See the textfield()
  3120. section for details on when these handlers are called.
  3121.  
  3122. =head2 CREATING A SCROLLING LIST
  3123.  
  3124.    print $query->scrolling_list('list_name',
  3125.                 ['eenie','meenie','minie','moe'],
  3126.                 ['eenie','moe'],5,'true');
  3127.       -or-
  3128.  
  3129.    print $query->scrolling_list('list_name',
  3130.                 ['eenie','meenie','minie','moe'],
  3131.                 ['eenie','moe'],5,'true',
  3132.                 \%labels);
  3133.  
  3134.     -or-
  3135.  
  3136.    print $query->scrolling_list(-name=>'list_name',
  3137.                 -values=>['eenie','meenie','minie','moe'],
  3138.                 -default=>['eenie','moe'],
  3139.                 -size=>5,
  3140.                 -multiple=>'true',
  3141.                 -labels=>\%labels);
  3142.  
  3143. scrolling_list() creates a scrolling list.  
  3144.  
  3145. =over 4
  3146.  
  3147. =item B<Parameters:>
  3148.  
  3149. =item 1.
  3150.  
  3151. The first and second arguments are the list name (-name) and values
  3152. (-values).  As in the popup menu, the second argument should be an
  3153. array reference.
  3154.  
  3155. =item 2.
  3156.  
  3157. The optional third argument (-default) can be either a reference to a
  3158. list containing the values to be selected by default, or can be a
  3159. single value to select.  If this argument is missing or undefined,
  3160. then nothing is selected when the list first appears.  In the named
  3161. parameter version, you can use the synonym "-defaults" for this
  3162. parameter.
  3163.  
  3164. =item 3.
  3165.  
  3166. The optional fourth argument is the size of the list (-size).
  3167.  
  3168. =item 4.
  3169.  
  3170. The optional fifth argument can be set to true to allow multiple
  3171. simultaneous selections (-multiple).  Otherwise only one selection
  3172. will be allowed at a time.
  3173.  
  3174. =item 5.
  3175.  
  3176. The optional sixth argument is a pointer to an associative array
  3177. containing long user-visible labels for the list items (-labels).
  3178. If not provided, the values will be displayed.
  3179.  
  3180. When this form is processed, all selected list items will be returned as
  3181. a list under the parameter name 'list_name'.  The values of the
  3182. selected items can be retrieved with:
  3183.  
  3184.       @selected = $query->param('list_name');
  3185.  
  3186. =back
  3187.  
  3188. JAVASCRIPTING: scrolling_list() recognizes the following event handlers:
  3189. B<-onChange>, B<-onFocus>, and B<-onBlur>.  See textfield() for
  3190. the description of when these handlers are called.
  3191.  
  3192. =head2 CREATING A GROUP OF RELATED CHECKBOXES
  3193.  
  3194.    print $query->checkbox_group(-name=>'group_name',
  3195.                 -values=>['eenie','meenie','minie','moe'],
  3196.                 -default=>['eenie','moe'],
  3197.                 -linebreak=>'true',
  3198.                 -labels=>\%labels);
  3199.  
  3200.    print $query->checkbox_group('group_name',
  3201.                 ['eenie','meenie','minie','moe'],
  3202.                 ['eenie','moe'],'true',\%labels);
  3203.  
  3204.    HTML3-COMPATIBLE BROWSERS ONLY:
  3205.  
  3206.    print $query->checkbox_group(-name=>'group_name',
  3207.                 -values=>['eenie','meenie','minie','moe'],
  3208.                 -rows=2,-columns=>2);
  3209.     
  3210.  
  3211. checkbox_group() creates a list of checkboxes that are related
  3212. by the same name.
  3213.  
  3214. =over 4
  3215.  
  3216. =item B<Parameters:>
  3217.  
  3218. =item 1.
  3219.  
  3220. The first and second arguments are the checkbox name and values,
  3221. respectively (-name and -values).  As in the popup menu, the second
  3222. argument should be an array reference.  These values are used for the
  3223. user-readable labels printed next to the checkboxes as well as for the
  3224. values passed to your script in the query string.
  3225.  
  3226. =item 2.
  3227.  
  3228. The optional third argument (-default) can be either a reference to a
  3229. list containing the values to be checked by default, or can be a
  3230. single value to checked.  If this argument is missing or undefined,
  3231. then nothing is selected when the list first appears.
  3232.  
  3233. =item 3.
  3234.  
  3235. The optional fourth argument (-linebreak) can be set to true to place
  3236. line breaks between the checkboxes so that they appear as a vertical
  3237. list.  Otherwise, they will be strung together on a horizontal line.
  3238.  
  3239. =item 4.
  3240.  
  3241. The optional fifth argument is a pointer to an associative array
  3242. relating the checkbox values to the user-visible labels that will
  3243. be printed next to them (-labels).  If not provided, the values will
  3244. be used as the default.
  3245.  
  3246. =item 5.
  3247.  
  3248. B<HTML3-compatible browsers> (such as Netscape) can take advantage 
  3249. of the optional 
  3250. parameters B<-rows>, and B<-columns>.  These parameters cause
  3251. checkbox_group() to return an HTML3 compatible table containing
  3252. the checkbox group formatted with the specified number of rows
  3253. and columns.  You can provide just the -columns parameter if you
  3254. wish; checkbox_group will calculate the correct number of rows
  3255. for you.
  3256.  
  3257. To include row and column headings in the returned table, you
  3258. can use the B<-rowheader> and B<-colheader> parameters.  Both
  3259. of these accept a pointer to an array of headings to use.
  3260. The headings are just decorative.  They don't reorganize the
  3261. interpretation of the checkboxes -- they're still a single named
  3262. unit.
  3263.  
  3264. =back
  3265.  
  3266. When the form is processed, all checked boxes will be returned as
  3267. a list under the parameter name 'group_name'.  The values of the
  3268. "on" checkboxes can be retrieved with:
  3269.  
  3270.       @turned_on = $query->param('group_name');
  3271.  
  3272. The value returned by checkbox_group() is actually an array of button
  3273. elements.  You can capture them and use them within tables, lists,
  3274. or in other creative ways:
  3275.  
  3276.     @h = $query->checkbox_group(-name=>'group_name',-values=>\@values);
  3277.     &use_in_creative_way(@h);
  3278.  
  3279. JAVASCRIPTING: checkbox_group() recognizes the B<-onClick>
  3280. parameter.  This specifies a JavaScript code fragment or
  3281. function call to be executed every time the user clicks on
  3282. any of the buttons in the group.  You can retrieve the identity
  3283. of the particular button clicked on using the "this" variable.
  3284.  
  3285. =head2 CREATING A STANDALONE CHECKBOX
  3286.  
  3287.     print $query->checkbox(-name=>'checkbox_name',
  3288.                -checked=>'checked',
  3289.                -value=>'ON',
  3290.                -label=>'CLICK ME');
  3291.  
  3292.     -or-
  3293.  
  3294.     print $query->checkbox('checkbox_name','checked','ON','CLICK ME');
  3295.  
  3296. checkbox() is used to create an isolated checkbox that isn't logically
  3297. related to any others.
  3298.  
  3299. =over 4
  3300.  
  3301. =item B<Parameters:>
  3302.  
  3303. =item 1.
  3304.  
  3305. The first parameter is the required name for the checkbox (-name).  It
  3306. will also be used for the user-readable label printed next to the
  3307. checkbox.
  3308.  
  3309. =item 2.
  3310.  
  3311. The optional second parameter (-checked) specifies that the checkbox
  3312. is turned on by default.  Synonyms are -selected and -on.
  3313.  
  3314. =item 3.
  3315.  
  3316. The optional third parameter (-value) specifies the value of the
  3317. checkbox when it is checked.  If not provided, the word "on" is
  3318. assumed.
  3319.  
  3320. =item 4.
  3321.  
  3322. The optional fourth parameter (-label) is the user-readable label to
  3323. be attached to the checkbox.  If not provided, the checkbox name is
  3324. used.
  3325.  
  3326. =back
  3327.  
  3328. The value of the checkbox can be retrieved using:
  3329.  
  3330.     $turned_on = $query->param('checkbox_name');
  3331.  
  3332. JAVASCRIPTING: checkbox() recognizes the B<-onClick>
  3333. parameter.  See checkbox_group() for further details.
  3334.  
  3335. =head2 CREATING A RADIO BUTTON GROUP
  3336.  
  3337.    print $query->radio_group(-name=>'group_name',
  3338.                  -values=>['eenie','meenie','minie'],
  3339.                  -default=>'meenie',
  3340.                  -linebreak=>'true',
  3341.                  -labels=>\%labels);
  3342.  
  3343.     -or-
  3344.  
  3345.    print $query->radio_group('group_name',['eenie','meenie','minie'],
  3346.                       'meenie','true',\%labels);
  3347.  
  3348.  
  3349.    HTML3-COMPATIBLE BROWSERS ONLY:
  3350.  
  3351.    print $query->radio_group(-name=>'group_name',
  3352.                  -values=>['eenie','meenie','minie','moe'],
  3353.                  -rows=2,-columns=>2);
  3354.  
  3355. radio_group() creates a set of logically-related radio buttons
  3356. (turning one member of the group on turns the others off)
  3357.  
  3358. =over 4
  3359.  
  3360. =item B<Parameters:>
  3361.  
  3362. =item 1.
  3363.  
  3364. The first argument is the name of the group and is required (-name).
  3365.  
  3366. =item 2.
  3367.  
  3368. The second argument (-values) is the list of values for the radio
  3369. buttons.  The values and the labels that appear on the page are
  3370. identical.  Pass an array I<reference> in the second argument, either
  3371. using an anonymous array, as shown, or by referencing a named array as
  3372. in "\@foo".
  3373.  
  3374. =item 3.
  3375.  
  3376. The optional third parameter (-default) is the name of the default
  3377. button to turn on. If not specified, the first item will be the
  3378. default.  You can provide a nonexistent button name, such as "-" to
  3379. start up with no buttons selected.
  3380.  
  3381. =item 4.
  3382.  
  3383. The optional fourth parameter (-linebreak) can be set to 'true' to put
  3384. line breaks between the buttons, creating a vertical list.
  3385.  
  3386. =item 5.
  3387.  
  3388. The optional fifth parameter (-labels) is a pointer to an associative
  3389. array relating the radio button values to user-visible labels to be
  3390. used in the display.  If not provided, the values themselves are
  3391. displayed.
  3392.  
  3393. =item 6.
  3394.  
  3395. B<HTML3-compatible browsers> (such as Netscape) can take advantage 
  3396. of the optional 
  3397. parameters B<-rows>, and B<-columns>.  These parameters cause
  3398. radio_group() to return an HTML3 compatible table containing
  3399. the radio group formatted with the specified number of rows
  3400. and columns.  You can provide just the -columns parameter if you
  3401. wish; radio_group will calculate the correct number of rows
  3402. for you.
  3403.  
  3404. To include row and column headings in the returned table, you
  3405. can use the B<-rowheader> and B<-colheader> parameters.  Both
  3406. of these accept a pointer to an array of headings to use.
  3407. The headings are just decorative.  They don't reorganize the
  3408. interpetation of the radio buttons -- they're still a single named
  3409. unit.
  3410.  
  3411. =back
  3412.  
  3413. When the form is processed, the selected radio button can
  3414. be retrieved using:
  3415.  
  3416.       $which_radio_button = $query->param('group_name');
  3417.  
  3418. The value returned by radio_group() is actually an array of button
  3419. elements.  You can capture them and use them within tables, lists,
  3420. or in other creative ways:
  3421.  
  3422.     @h = $query->radio_group(-name=>'group_name',-values=>\@values);
  3423.     &use_in_creative_way(@h);
  3424.  
  3425. =head2 CREATING A SUBMIT BUTTON 
  3426.  
  3427.    print $query->submit(-name=>'button_name',
  3428.             -value=>'value');
  3429.  
  3430.     -or-
  3431.  
  3432.    print $query->submit('button_name','value');
  3433.  
  3434. submit() will create the query submission button.  Every form
  3435. should have one of these.
  3436.  
  3437. =over 4
  3438.  
  3439. =item B<Parameters:>
  3440.  
  3441. =item 1.
  3442.  
  3443. The first argument (-name) is optional.  You can give the button a
  3444. name if you have several submission buttons in your form and you want
  3445. to distinguish between them.  The name will also be used as the
  3446. user-visible label.  Be aware that a few older browsers don't deal with this correctly and
  3447. B<never> send back a value from a button.
  3448.  
  3449. =item 2.
  3450.  
  3451. The second argument (-value) is also optional.  This gives the button
  3452. a value that will be passed to your script in the query string.
  3453.  
  3454. =back
  3455.  
  3456. You can figure out which button was pressed by using different
  3457. values for each one:
  3458.  
  3459.      $which_one = $query->param('button_name');
  3460.  
  3461. JAVASCRIPTING: radio_group() recognizes the B<-onClick>
  3462. parameter.  See checkbox_group() for further details.
  3463.  
  3464. =head2 CREATING A RESET BUTTON
  3465.  
  3466.    print $query->reset
  3467.  
  3468. reset() creates the "reset" button.  Note that it restores the
  3469. form to its value from the last time the script was called, 
  3470. NOT necessarily to the defaults.
  3471.  
  3472. =head2 CREATING A DEFAULT BUTTON
  3473.  
  3474.    print $query->defaults('button_label')
  3475.  
  3476. defaults() creates a button that, when invoked, will cause the
  3477. form to be completely reset to its defaults, wiping out all the
  3478. changes the user ever made.
  3479.  
  3480. =head2 CREATING A HIDDEN FIELD
  3481.  
  3482.     print $query->hidden(-name=>'hidden_name',
  3483.                  -default=>['value1','value2'...]);
  3484.  
  3485.         -or-
  3486.  
  3487.     print $query->hidden('hidden_name','value1','value2'...);
  3488.  
  3489. hidden() produces a text field that can't be seen by the user.  It
  3490. is useful for passing state variable information from one invocation
  3491. of the script to the next.
  3492.  
  3493. =over 4
  3494.  
  3495. =item B<Parameters:>
  3496.  
  3497. =item 1.
  3498.  
  3499. The first argument is required and specifies the name of this
  3500. field (-name).
  3501.  
  3502. =item 2.  
  3503.  
  3504. The second argument is also required and specifies its value
  3505. (-default).  In the named parameter style of calling, you can provide
  3506. a single value here or a reference to a whole list
  3507.  
  3508. =back
  3509.  
  3510. Fetch the value of a hidden field this way:
  3511.  
  3512.      $hidden_value = $query->param('hidden_name');
  3513.  
  3514. Note, that just like all the other form elements, the value of a
  3515. hidden field is "sticky".  If you want to replace a hidden field with
  3516. some other values after the script has been called once you'll have to
  3517. do it manually:
  3518.  
  3519.      $query->param('hidden_name','new','values','here');
  3520.  
  3521. =head2 CREATING A CLICKABLE IMAGE BUTTON
  3522.  
  3523.      print $query->image_button(-name=>'button_name',
  3524.                 -src=>'/source/URL',
  3525.                 -align=>'MIDDLE');      
  3526.  
  3527.     -or-
  3528.  
  3529.      print $query->image_button('button_name','/source/URL','MIDDLE');
  3530.  
  3531. image_button() produces a clickable image.  When it's clicked on the
  3532. position of the click is returned to your script as "button_name.x"
  3533. and "button_name.y", where "button_name" is the name you've assigned
  3534. to it.
  3535.  
  3536. JAVASCRIPTING: image_button() recognizes the B<-onClick>
  3537. parameter.  See checkbox_group() for further details.
  3538.  
  3539. =over 4
  3540.  
  3541. =item B<Parameters:>
  3542.  
  3543. =item 1.
  3544.  
  3545. The first argument (-name) is required and specifies the name of this
  3546. field.
  3547.  
  3548. =item 2.
  3549.  
  3550. The second argument (-src) is also required and specifies the URL
  3551.  
  3552. =item 3.
  3553. The third option (-align, optional) is an alignment type, and may be
  3554. TOP, BOTTOM or MIDDLE
  3555.  
  3556. =back
  3557.  
  3558. Fetch the value of the button this way:
  3559.      $x = $query->param('button_name.x');
  3560.      $y = $query->param('button_name.y');
  3561.  
  3562. =head2 CREATING A JAVASCRIPT ACTION BUTTON
  3563.  
  3564.      print $query->button(-name=>'button_name',
  3565.               -value=>'user visible label',
  3566.               -onClick=>"do_something()");
  3567.  
  3568.     -or-
  3569.  
  3570.      print $query->button('button_name',"do_something()");
  3571.  
  3572. button() produces a button that is compatible with Netscape 2.0's
  3573. JavaScript.  When it's pressed the fragment of JavaScript code
  3574. pointed to by the B<-onClick> parameter will be executed.  On
  3575. non-Netscape browsers this form element will probably not even
  3576. display.
  3577.  
  3578. =head1 NETSCAPE COOKIES
  3579.  
  3580. Netscape browsers versions 1.1 and higher support a so-called
  3581. "cookie" designed to help maintain state within a browser session.
  3582. CGI.pm has several methods that support cookies.
  3583.  
  3584. A cookie is a name=value pair much like the named parameters in a CGI
  3585. query string.  CGI scripts create one or more cookies and send
  3586. them to the browser in the HTTP header.  The browser maintains a list
  3587. of cookies that belong to a particular Web server, and returns them
  3588. to the CGI script during subsequent interactions.
  3589.  
  3590. In addition to the required name=value pair, each cookie has several
  3591. optional attributes:
  3592.  
  3593. =over 4
  3594.  
  3595. =item 1. an expiration time
  3596.  
  3597. This is a time/date string (in a special GMT format) that indicates
  3598. when a cookie expires.  The cookie will be saved and returned to your
  3599. script until this expiration date is reached if the user exits
  3600. Netscape and restarts it.  If an expiration date isn't specified, the cookie
  3601. will remain active until the user quits Netscape.
  3602.  
  3603. =item 2. a domain
  3604.  
  3605. This is a partial or complete domain name for which the cookie is 
  3606. valid.  The browser will return the cookie to any host that matches
  3607. the partial domain name.  For example, if you specify a domain name
  3608. of ".capricorn.com", then Netscape will return the cookie to
  3609. Web servers running on any of the machines "www.capricorn.com", 
  3610. "www2.capricorn.com", "feckless.capricorn.com", etc.  Domain names
  3611. must contain at least two periods to prevent attempts to match
  3612. on top level domains like ".edu".  If no domain is specified, then
  3613. the browser will only return the cookie to servers on the host the
  3614. cookie originated from.
  3615.  
  3616. =item 3. a path
  3617.  
  3618. If you provide a cookie path attribute, the browser will check it
  3619. against your script's URL before returning the cookie.  For example,
  3620. if you specify the path "/cgi-bin", then the cookie will be returned
  3621. to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
  3622. and "/cgi-bin/customer_service/complain.pl", but not to the script
  3623. "/cgi-private/site_admin.pl".  By default, path is set to "/", which
  3624. causes the cookie to be sent to any CGI script on your site.
  3625.  
  3626. =item 4. a "secure" flag
  3627.  
  3628. If the "secure" attribute is set, the cookie will only be sent to your
  3629. script if the CGI request is occurring on a secure channel, such as SSL.
  3630.  
  3631. =back
  3632.  
  3633. The interface to Netscape cookies is the B<cookie()> method:
  3634.  
  3635.     $cookie = $query->cookie(-name=>'sessionID',
  3636.                  -value=>'xyzzy',
  3637.                  -expires=>'+1h',
  3638.                  -path=>'/cgi-bin/database',
  3639.                  -domain=>'.capricorn.org',
  3640.                  -secure=>1);
  3641.     print $query->header(-cookie=>$cookie);
  3642.  
  3643. B<cookie()> creates a new cookie.  Its parameters include:
  3644.  
  3645. =over 4
  3646.  
  3647. =item B<-name>
  3648.  
  3649. The name of the cookie (required).  This can be any string at all.
  3650. Although Netscape limits its cookie names to non-whitespace
  3651. alphanumeric characters, CGI.pm removes this restriction by escaping
  3652. and unescaping cookies behind the scenes.
  3653.  
  3654. =item B<-value>
  3655.  
  3656. The value of the cookie.  This can be any scalar value,
  3657. array reference, or even associative array reference.  For example,
  3658. you can store an entire associative array into a cookie this way:
  3659.  
  3660.     $cookie=$query->cookie(-name=>'family information',
  3661.                    -value=>\%childrens_ages);
  3662.  
  3663. =item B<-path>
  3664.  
  3665. The optional partial path for which this cookie will be valid, as described
  3666. above.
  3667.  
  3668. =item B<-domain>
  3669.  
  3670. The optional partial domain for which this cookie will be valid, as described
  3671. above.
  3672.  
  3673. =item B<-expires>
  3674.  
  3675. The optional expiration date for this cookie.  The format is as described 
  3676. in the section on the B<header()> method:
  3677.  
  3678.     "+1h"  one hour from now
  3679.  
  3680. =item B<-secure>
  3681.  
  3682. If set to true, this cookie will only be used within a secure
  3683. SSL session.
  3684.  
  3685. =back
  3686.  
  3687. The cookie created by cookie() must be incorporated into the HTTP
  3688. header within the string returned by the header() method:
  3689.  
  3690.     print $query->header(-cookie=>$my_cookie);
  3691.  
  3692. To create multiple cookies, give header() an array reference:
  3693.  
  3694.     $cookie1 = $query->cookie(-name=>'riddle_name',
  3695.                   -value=>"The Sphynx's Question");
  3696.     $cookie2 = $query->cookie(-name=>'answers',
  3697.                   -value=>\%answers);
  3698.     print $query->header(-cookie=>[$cookie1,$cookie2]);
  3699.  
  3700. To retrieve a cookie, request it by name by calling cookie()
  3701. method without the B<-value> parameter:
  3702.  
  3703.     use CGI;
  3704.     $query = new CGI;
  3705.     %answers = $query->cookie(-name=>'answers');
  3706.  
  3707. The cookie and CGI namespaces are separate.  If you have a parameter
  3708. named 'answers' and a cookie named 'answers', the values retrieved by
  3709. param() and cookie() are independent of each other.  However, it's
  3710. simple to turn a CGI parameter into a cookie, and vice-versa:
  3711.  
  3712.    $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]);
  3713.    $q->param(-name=>'answers',-value=>[$q->cookie('answers')]);
  3714.  
  3715. See the B<cookie.cgi> example script for some ideas on how to use
  3716. cookies effectively.
  3717.  
  3718. B<NOTE:> There appear to be some (undocumented) restrictions on
  3719. Netscape cookies.  In Netscape 2.01, at least, I haven't been able to
  3720. set more than three cookies at a time.  There may also be limits on
  3721. the length of cookies.  If you need to store a lot of information,
  3722. it's probably better to create a unique session ID, store it in a
  3723. cookie, and use the session ID to locate an external file/database
  3724. saved on the server's side of the connection.
  3725.  
  3726. =head1 WORKING WITH NETSCAPE FRAMES
  3727.  
  3728. It's possible for CGI.pm scripts to write into several browser
  3729. panels and windows using Netscape's frame mechanism.  
  3730. There are three techniques for defining new frames programmatically:
  3731.  
  3732. =over 4
  3733.  
  3734. =item 1. Create a <Frameset> document
  3735.  
  3736. After writing out the HTTP header, instead of creating a standard
  3737. HTML document using the start_html() call, create a <FRAMESET> 
  3738. document that defines the frames on the page.  Specify your script(s)
  3739. (with appropriate parameters) as the SRC for each of the frames.
  3740.  
  3741. There is no specific support for creating <FRAMESET> sections 
  3742. in CGI.pm, but the HTML is very simple to write.  See the frame
  3743. documentation in Netscape's home pages for details 
  3744.  
  3745.   http://home.netscape.com/assist/net_sites/frames.html
  3746.  
  3747. =item 2. Specify the destination for the document in the HTTP header
  3748.  
  3749. You may provide a B<-target> parameter to the header() method:
  3750.    
  3751.     print $q->header(-target=>'ResultsWindow');
  3752.  
  3753. This will tell Netscape to load the output of your script into the
  3754. frame named "ResultsWindow".  If a frame of that name doesn't
  3755. already exist, Netscape will pop up a new window and load your
  3756. script's document into that.  There are a number of magic names
  3757. that you can use for targets.  See the frame documents on Netscape's
  3758. home pages for details.
  3759.  
  3760. =item 3. Specify the destination for the document in the <FORM> tag
  3761.  
  3762. You can specify the frame to load in the FORM tag itself.  With
  3763. CGI.pm it looks like this:
  3764.  
  3765.     print $q->startform(-target=>'ResultsWindow');
  3766.  
  3767. When your script is reinvoked by the form, its output will be loaded
  3768. into the frame named "ResultsWindow".  If one doesn't already exist
  3769. a new window will be created.
  3770.  
  3771. =back
  3772.  
  3773. The script "frameset.cgi" in the examples directory shows one way to
  3774. create pages in which the fill-out form and the response live in
  3775. side-by-side frames.
  3776.  
  3777. =head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
  3778.  
  3779. CGI.pm has limited support for HTML3's cascading style sheets (css).
  3780. To incorporate a stylesheet into your document, pass the
  3781. start_html() method a B<-style> parameter.  The value of this
  3782. parameter may be a scalar, in which case it is incorporated directly
  3783. into a <STYLE> section, or it may be a hash reference.  In the latter
  3784. case you should provide the hash with one or more of B<-src> or
  3785. B<-code>.  B<-src> points to a URL where an externally-defined
  3786. stylesheet can be found.  B<-code> points to a scalar value to be
  3787. incorporated into a <STYLE> section.  Style definitions in B<-code>
  3788. override similarly-named ones in B<-src>, hence the name "cascading."
  3789.  
  3790. To refer to a style within the body of your document, add the
  3791. B<-class> parameter to any HTML element:
  3792.  
  3793.     print h1({-class=>'Fancy'},'Welcome to the Party');
  3794.  
  3795. Or define styles on the fly with the B<-style> parameter:
  3796.  
  3797.     print h1({-style=>'Color: red;'},'Welcome to Hell');
  3798.  
  3799. You may also use the new B<span()> element to apply a style to a
  3800. section of text:
  3801.  
  3802.     print span({-style=>'Color: red;'},
  3803.            h1('Welcome to Hell'),
  3804.            "Where did that handbasket get to?"
  3805.            );
  3806.  
  3807. Note that you must import the ":html3" definitions to have the
  3808. B<span()> method available.  Here's a quick and dirty example of using
  3809. CSS's.  See the CSS specification at
  3810. http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
  3811.  
  3812.     use CGI qw/:standard :html3/;
  3813.  
  3814.     $newStyle=<<END;
  3815.     <!-- 
  3816.     P.Tip {
  3817.     margin-right: 50pt;
  3818.     margin-left: 50pt;
  3819.         color: red;
  3820.     }
  3821.     P.Alert {
  3822.     font-size: 30pt;
  3823.         font-family: sans-serif;
  3824.       color: red;
  3825.     }
  3826.     -->
  3827.     END
  3828.     print header();
  3829.     print start_html( -title=>'CGI with Style',
  3830.               -style=>{-src=>'http://www.capricorn.com/style/st1.css',
  3831.                        -code=>$newStyle}
  3832.                  );
  3833.     print h1('CGI with Style'),
  3834.           p({-class=>'Tip'},
  3835.         "Better read the cascading style sheet spec before playing with this!"),
  3836.           span({-style=>'color: magenta'},
  3837.            "Look Mom, no hands!",
  3838.            p(),
  3839.            "Whooo wee!"
  3840.            );
  3841.     print end_html;
  3842.  
  3843. =head1 DEBUGGING
  3844.  
  3845. If you are running the script
  3846. from the command line or in the perl debugger, you can pass the script
  3847. a list of keywords or parameter=value pairs on the command line or 
  3848. from standard input (you don't have to worry about tricking your
  3849. script into reading from environment variables).
  3850. You can pass keywords like this:
  3851.  
  3852.     your_script.pl keyword1 keyword2 keyword3
  3853.  
  3854. or this:
  3855.  
  3856.    your_script.pl keyword1+keyword2+keyword3
  3857.  
  3858. or this:
  3859.  
  3860.     your_script.pl name1=value1 name2=value2
  3861.  
  3862. or this:
  3863.  
  3864.     your_script.pl name1=value1&name2=value2
  3865.  
  3866. or even as newline-delimited parameters on standard input.
  3867.  
  3868. When debugging, you can use quotes and backslashes to escape 
  3869. characters in the familiar shell manner, letting you place
  3870. spaces and other funny characters in your parameter=value
  3871. pairs:
  3872.  
  3873.    your_script.pl "name1='I am a long value'" "name2=two\ words"
  3874.  
  3875. =head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
  3876.  
  3877. The dump() method produces a string consisting of all the query's
  3878. name/value pairs formatted nicely as a nested list.  This is useful
  3879. for debugging purposes:
  3880.  
  3881.     print $query->dump
  3882.     
  3883.  
  3884. Produces something that looks like:
  3885.  
  3886.     <UL>
  3887.     <LI>name1
  3888.     <UL>
  3889.     <LI>value1
  3890.     <LI>value2
  3891.     </UL>
  3892.     <LI>name2
  3893.     <UL>
  3894.     <LI>value1
  3895.     </UL>
  3896.     </UL>
  3897.  
  3898. You can pass a value of 'true' to dump() in order to get it to
  3899. print the results out as plain text, suitable for incorporating
  3900. into a <PRE> section.
  3901.  
  3902. As a shortcut, as of version 1.56 you can interpolate the entire CGI
  3903. object into a string and it will be replaced with the a nice HTML dump
  3904. shown above:
  3905.  
  3906.     $query=new CGI;
  3907.     print "<H2>Current Values</H2> $query\n";
  3908.  
  3909. =head1 FETCHING ENVIRONMENT VARIABLES
  3910.  
  3911. Some of the more useful environment variables can be fetched
  3912. through this interface.  The methods are as follows:
  3913.  
  3914. =over 4
  3915.  
  3916. =item B<accept()>
  3917.  
  3918. Return a list of MIME types that the remote browser
  3919. accepts. If you give this method a single argument
  3920. corresponding to a MIME type, as in
  3921. $query->accept('text/html'), it will return a
  3922. floating point value corresponding to the browser's
  3923. preference for this type from 0.0 (don't want) to 1.0.
  3924. Glob types (e.g. text/*) in the browser's accept list
  3925. are handled correctly.
  3926.  
  3927. =item B<raw_cookie()>
  3928.  
  3929. Returns the HTTP_COOKIE variable, an HTTP extension
  3930. implemented by Netscape browsers version 1.1
  3931. and higher.  Cookies have a special format, and this 
  3932. method call just returns the raw form (?cookie dough).
  3933. See cookie() for ways of setting and retrieving
  3934. cooked cookies.
  3935.  
  3936. =item B<user_agent()>
  3937.  
  3938. Returns the HTTP_USER_AGENT variable.  If you give
  3939. this method a single argument, it will attempt to
  3940. pattern match on it, allowing you to do something
  3941. like $query->user_agent(netscape);
  3942.  
  3943. =item B<path_info()>
  3944.  
  3945. Returns additional path information from the script URL.
  3946. E.G. fetching /cgi-bin/your_script/additional/stuff will
  3947. result in $query->path_info() returning
  3948. "additional/stuff".
  3949.  
  3950. NOTE: The Microsoft Internet Information Server
  3951. is broken with respect to additional path information.  If
  3952. you use the Perl DLL library, the IIS server will attempt to
  3953. execute the additional path information as a Perl script.
  3954. If you use the ordinary file associations mapping, the
  3955. path information will be present in the environment, 
  3956. but incorrect.  The best thing to do is to avoid using additional
  3957. path information in CGI scripts destined for use with IIS.
  3958.  
  3959. =item B<path_translated()>
  3960.  
  3961. As per path_info() but returns the additional
  3962. path information translated into a physical path, e.g.
  3963. "/usr/local/etc/httpd/htdocs/additional/stuff".
  3964.  
  3965. The Microsoft IIS is broken with respect to the translated
  3966. path as well.
  3967.  
  3968. =item B<remote_host()>
  3969.  
  3970. Returns either the remote host name or IP address.
  3971. if the former is unavailable.
  3972.  
  3973. =item B<script_name()>
  3974. Return the script name as a partial URL, for self-refering
  3975. scripts.
  3976.  
  3977. =item B<referer()>
  3978.  
  3979. Return the URL of the page the browser was viewing
  3980. prior to fetching your script.  Not available for all
  3981. browsers.
  3982.  
  3983. =item B<auth_type ()>
  3984.  
  3985. Return the authorization/verification method in use for this
  3986. script, if any.
  3987.  
  3988. =item B<server_name ()>
  3989.  
  3990. Returns the name of the server, usually the machine's host
  3991. name.
  3992.  
  3993. =item B<virtual_host ()>
  3994.  
  3995. When using virtual hosts, returns the name of the host that
  3996. the browser attempted to contact
  3997.  
  3998. =item B<server_software ()>
  3999.  
  4000. Returns the server software and version number.
  4001.  
  4002. =item B<remote_user ()>
  4003.  
  4004. Return the authorization/verification name used for user
  4005. verification, if this script is protected.
  4006.  
  4007. =item B<user_name ()>
  4008.  
  4009. Attempt to obtain the remote user's name, using a variety
  4010. of different techniques.  This only works with older browsers
  4011. such as Mosaic.  Netscape does not reliably report the user
  4012. name!
  4013.  
  4014. =item B<request_method()>
  4015.  
  4016. Returns the method used to access your script, usually
  4017. one of 'POST', 'GET' or 'HEAD'.
  4018.  
  4019. =back
  4020.  
  4021. =head1 CREATING HTML ELEMENTS
  4022.  
  4023. In addition to its shortcuts for creating form elements, CGI.pm
  4024. defines general HTML shortcut methods as well.  HTML shortcuts are
  4025. named after a single HTML element and return a fragment of HTML text
  4026. that you can then print or manipulate as you like.
  4027.  
  4028. This example shows how to use the HTML methods:
  4029.  
  4030.     $q = new CGI;
  4031.     print $q->blockquote(
  4032.                  "Many years ago on the island of",
  4033.                  $q->a({href=>"http://crete.org/"},"Crete"),
  4034.                  "there lived a minotaur named",
  4035.                  $q->strong("Fred."),
  4036.                 ),
  4037.            $q->hr;
  4038.  
  4039. This results in the following HTML code (extra newlines have been
  4040. added for readability):
  4041.  
  4042.     <blockquote>
  4043.     Many years ago on the island of
  4044.     <a HREF="http://crete.org/">Crete</a> there lived
  4045.     a minotaur named <strong>Fred.</strong> 
  4046.     </blockquote>
  4047.     <hr>
  4048.  
  4049. If you find the syntax for calling the HTML shortcuts awkward, you can
  4050. import them into your namespace and dispense with the object syntax
  4051. completely (see the next section for more details):
  4052.  
  4053.     use CGI shortcuts;      # IMPORT HTML SHORTCUTS
  4054.     print blockquote(
  4055.              "Many years ago on the island of",
  4056.              a({href=>"http://crete.org/"},"Crete"),
  4057.              "there lived a minotaur named",
  4058.              strong("Fred."),
  4059.              ),
  4060.            hr;
  4061.  
  4062. =head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
  4063.  
  4064. The HTML methods will accept zero, one or multiple arguments.  If you
  4065. provide no arguments, you get a single tag:
  4066.  
  4067.     print hr;  
  4068.  
  4069. If you provide one or more string arguments, they are concatenated
  4070. together with spaces and placed between opening and closing tags:
  4071.  
  4072.     print h1("Chapter","1"); 
  4073.  
  4074. If the first argument is an associative array reference, then the keys
  4075. and values of the associative array become the HTML tag's attributes:
  4076.  
  4077.     print a({href=>'fred.html',target=>'_new'},
  4078.         "Open a new frame");
  4079.  
  4080. You are free to use CGI.pm-style dashes in front of the attribute
  4081. names if you prefer:
  4082.  
  4083.     print img {-src=>'fred.gif',-align=>'LEFT'};
  4084.  
  4085. =head2 Generating new HTML tags
  4086.  
  4087. Since no mere mortal can keep up with Netscape and Microsoft as they
  4088. battle it out for control of HTML, the code that generates HTML tags
  4089. is general and extensible.  You can create new HTML tags freely just
  4090. by referring to them on the import line:
  4091.  
  4092.     use CGI shortcuts,winkin,blinkin,nod;
  4093.  
  4094. Now, in addition to the standard CGI shortcuts, you've created HTML
  4095. tags named "winkin", "blinkin" and "nod".  You can use them like this:
  4096.  
  4097.     print blinkin {color=>'blue',rate=>'fast'},"Yahoo!";
  4098.  
  4099. =head1 IMPORTING CGI METHOD CALLS INTO YOUR NAME SPACE
  4100.  
  4101. As a convenience, you can import most of the CGI method calls directly
  4102. into your name space.  The syntax for doing this is:
  4103.  
  4104.     use CGI <list of methods>;
  4105.  
  4106. The listed methods will be imported into the current package; you can
  4107. call them directly without creating a CGI object first.  This example
  4108. shows how to import the B<param()> and B<header()>
  4109. methods, and then use them directly:
  4110.  
  4111.     use CGI param,header;
  4112.     print header('text/plain');
  4113.     $zipcode = param('zipcode');
  4114.  
  4115. You can import groups of methods by referring to a number of special
  4116. names:
  4117.  
  4118. =over 4
  4119.  
  4120. =item B<cgi>
  4121.  
  4122. Import all CGI-handling methods, such as B<param()>, B<path_info()>
  4123. and the like.
  4124.  
  4125. =item B<form>
  4126.  
  4127. Import all fill-out form generating methods, such as B<textfield()>.
  4128.  
  4129. =item B<html2>
  4130.  
  4131. Import all methods that generate HTML 2.0 standard elements.
  4132.  
  4133. =item B<html3>
  4134.  
  4135. Import all methods that generate HTML 3.0 proposed elements (such as
  4136. <table>, <super> and <sub>).
  4137.  
  4138. =item B<netscape>
  4139.  
  4140. Import all methods that generate Netscape-specific HTML extensions.
  4141.  
  4142. =item B<shortcuts>
  4143.  
  4144. Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
  4145. 'netscape')...
  4146.  
  4147. =item B<standard>
  4148.  
  4149. Import "standard" features, 'html2', 'form' and 'cgi'.
  4150.  
  4151. =item B<all>
  4152.  
  4153. Import all the available methods.  For the full list, see the CGI.pm
  4154. code, where the variable %TAGS is defined.
  4155.  
  4156. =back
  4157.  
  4158. Note that in the interests of execution speed CGI.pm does B<not> use
  4159. the standard L<Exporter> syntax for specifying load symbols.  This may
  4160. change in the future.
  4161.  
  4162. If you import any of the state-maintaining CGI or form-generating
  4163. methods, a default CGI object will be created and initialized
  4164. automatically the first time you use any of the methods that require
  4165. one to be present.  This includes B<param()>, B<textfield()>,
  4166. B<submit()> and the like.  (If you need direct access to the CGI
  4167. object, you can find it in the global variable B<$CGI::Q>).  By
  4168. importing CGI.pm methods, you can create visually elegant scripts:
  4169.  
  4170.    use CGI standard,html2;
  4171.    print 
  4172.        header,
  4173.        start_html('Simple Script'),
  4174.        h1('Simple Script'),
  4175.        start_form,
  4176.        "What's your name? ",textfield('name'),p,
  4177.        "What's the combination?",
  4178.        checkbox_group(-name=>'words',
  4179.               -values=>['eenie','meenie','minie','moe'],
  4180.               -defaults=>['eenie','moe']),p,
  4181.        "What's your favorite color?",
  4182.        popup_menu(-name=>'color',
  4183.           -values=>['red','green','blue','chartreuse']),p,
  4184.        submit,
  4185.        end_form,
  4186.        hr,"\n";
  4187.  
  4188.     if (param) {
  4189.        print 
  4190.        "Your name is ",em(param('name')),p,
  4191.        "The keywords are: ",em(join(", ",param('words'))),p,
  4192.        "Your favorite color is ",em(param('color')),".\n";
  4193.     }
  4194.     print end_html;
  4195.  
  4196. =head1 USING NPH SCRIPTS
  4197.  
  4198. NPH, or "no-parsed-header", scripts bypass the server completely by
  4199. sending the complete HTTP header directly to the browser.  This has
  4200. slight performance benefits, but is of most use for taking advantage
  4201. of HTTP extensions that are not directly supported by your server,
  4202. such as server push and PICS headers.
  4203.  
  4204. Servers use a variety of conventions for designating CGI scripts as
  4205. NPH.  Many Unix servers look at the beginning of the script's name for
  4206. the prefix "nph-".  The Macintosh WebSTAR server and Microsoft's
  4207. Internet Information Server, in contrast, try to decide whether a
  4208. program is an NPH script by examining the first line of script output.
  4209.  
  4210.  
  4211. CGI.pm supports NPH scripts with a special NPH mode.  When in this
  4212. mode, CGI.pm will output the necessary extra header information when
  4213. the header() and redirect() methods are
  4214. called.
  4215.  
  4216. The Microsoft Internet Information Server requires NPH mode.  As of version
  4217. 2.30, CGI.pm will automatically detect when the script is running under IIS
  4218. and put itself into this mode.  You do not need to do this manually, although
  4219. it won't hurt anything if you do.
  4220.  
  4221. There are a number of ways to put CGI.pm into NPH mode:
  4222.  
  4223. =over 4
  4224.  
  4225. =item In the B<use> statement
  4226. Simply add ":nph" to the list of symbols to be imported into your script:
  4227.  
  4228.       use CGI qw(:standard :nph)
  4229.  
  4230. =item By calling the B<nph()> method:
  4231.  
  4232. Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
  4233.  
  4234.       CGI->nph(1)
  4235.  
  4236. =item By using B<-nph> parameters in the B<header()> and B<redirect()>  statements:
  4237.  
  4238.       print $q->header(-nph=>1);
  4239.  
  4240. =back
  4241.  
  4242. =head1 AUTHOR INFORMATION
  4243.  
  4244. Copyright 1995,1996, Lincoln D. Stein.  All rights reserved.  It may
  4245. be used and modified freely, but I do request that this copyright
  4246. notice remain attached to the file.  You may modify this module as you
  4247. wish, but if you redistribute a modified version, please attach a note
  4248. listing the modifications you have made.
  4249.  
  4250. Address bug reports and comments to:
  4251. lstein@genome.wi.mit.edu
  4252.  
  4253. =head1 CREDITS
  4254.  
  4255. Thanks very much to:
  4256.  
  4257. =over 4
  4258.  
  4259. =item Matt Heffron (heffron@falstaff.css.beckman.com)
  4260.  
  4261. =item James Taylor (james.taylor@srs.gov)
  4262.  
  4263. =item Scott Anguish <sanguish@digifix.com>
  4264.  
  4265. =item Mike Jewell (mlj3u@virginia.edu)
  4266.  
  4267. =item Timothy Shimmin (tes@kbs.citri.edu.au)
  4268.  
  4269. =item Joergen Haegg (jh@axis.se)
  4270.  
  4271. =item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu)
  4272.  
  4273. =item Richard Resnick (applepi1@aol.com)
  4274.  
  4275. =item Craig Bishop (csb@barwonwater.vic.gov.au)
  4276.  
  4277. =item Tony Curtis (tc@vcpc.univie.ac.at)
  4278.  
  4279. =item Tim Bunce (Tim.Bunce@ig.co.uk)
  4280.  
  4281. =item Tom Christiansen (tchrist@convex.com)
  4282.  
  4283. =item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
  4284.  
  4285. =item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
  4286.  
  4287. =item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
  4288.  
  4289. =item Stephen Dahmen (joyfire@inxpress.net)
  4290.  
  4291. =item Ed Jordan (ed@fidalgo.net)
  4292.  
  4293. =item David Alan Pisoni (david@cnation.com)
  4294.  
  4295. =item ...and many many more...
  4296.  
  4297. for suggestions and bug fixes.
  4298.  
  4299. =back
  4300.  
  4301. =head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
  4302.  
  4303.  
  4304.      
  4305.     use CGI;
  4306.  
  4307.     $query = new CGI;
  4308.  
  4309.     print $query->header;
  4310.     print $query->start_html("Example CGI.pm Form");
  4311.     print "<H1> Example CGI.pm Form</H1>\n";
  4312.     &print_prompt($query);
  4313.     &do_work($query);
  4314.     &print_tail;
  4315.     print $query->end_html;
  4316.  
  4317.     sub print_prompt {
  4318.        my($query) = @_;
  4319.  
  4320.        print $query->startform;
  4321.        print "<EM>What's your name?</EM><BR>";
  4322.        print $query->textfield('name');
  4323.        print $query->checkbox('Not my real name');
  4324.  
  4325.        print "<P><EM>Where can you find English Sparrows?</EM><BR>";
  4326.        print $query->checkbox_group(
  4327.                  -name=>'Sparrow locations',
  4328.                  -values=>[England,France,Spain,Asia,Hoboken],
  4329.                  -linebreak=>'yes',
  4330.                  -defaults=>[England,Asia]);
  4331.  
  4332.        print "<P><EM>How far can they fly?</EM><BR>",
  4333.         $query->radio_group(
  4334.             -name=>'how far',
  4335.             -values=>['10 ft','1 mile','10 miles','real far'],
  4336.             -default=>'1 mile');
  4337.  
  4338.        print "<P><EM>What's your favorite color?</EM>  ";
  4339.        print $query->popup_menu(-name=>'Color',
  4340.                     -values=>['black','brown','red','yellow'],
  4341.                     -default=>'red');
  4342.  
  4343.        print $query->hidden('Reference','Monty Python and the Holy Grail');
  4344.  
  4345.        print "<P><EM>What have you got there?</EM><BR>";
  4346.        print $query->scrolling_list(
  4347.              -name=>'possessions',
  4348.              -values=>['A Coconut','A Grail','An Icon',
  4349.                    'A Sword','A Ticket'],
  4350.              -size=>5,
  4351.              -multiple=>'true');
  4352.  
  4353.        print "<P><EM>Any parting comments?</EM><BR>";
  4354.        print $query->textarea(-name=>'Comments',
  4355.                   -rows=>10,
  4356.                   -columns=>50);
  4357.  
  4358.        print "<P>",$query->reset;
  4359.        print $query->submit('Action','Shout');
  4360.        print $query->submit('Action','Scream');
  4361.        print $query->endform;
  4362.        print "<HR>\n";
  4363.     }
  4364.  
  4365.     sub do_work {
  4366.        my($query) = @_;
  4367.        my(@values,$key);
  4368.  
  4369.        print "<H2>Here are the current settings in this form</H2>";
  4370.  
  4371.        foreach $key ($query->param) {
  4372.           print "<STRONG>$key</STRONG> -> ";
  4373.           @values = $query->param($key);
  4374.           print join(", ",@values),"<BR>\n";
  4375.       }
  4376.     }
  4377.  
  4378.     sub print_tail {
  4379.        print <<END;
  4380.     <HR>
  4381.     <ADDRESS>Lincoln D. Stein</ADDRESS><BR>
  4382.     <A HREF="/">Home Page</A>
  4383.     END
  4384.     }
  4385.  
  4386. =head1 BUGS
  4387.  
  4388. This module has grown large and monolithic.  Furthermore it's doing many
  4389. things, such as handling URLs, parsing CGI input, writing HTML, etc., that
  4390. are also done in the LWP modules. It should be discarded in favor of
  4391. the CGI::* modules, but somehow I continue to work on it.
  4392.  
  4393. Note that the code is truly contorted in order to avoid spurious
  4394. warnings when programs are run with the B<-w> switch.
  4395.  
  4396. =head1 SEE ALSO
  4397.  
  4398. L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>,
  4399. L<CGI::Base>, L<CGI::Form>, L<CGI::Apache>, L<CGI::Switch>,
  4400. L<CGI::Push>, L<CGI::Fast>
  4401.  
  4402. =cut
  4403.  
  4404.